ACHSVDC ; IHS/ITSC/PMF - DOCUMENTS BY PROVIDER/VENDOR ; [ 12/23/2004 11:17 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,12,25**;JUN 11, 2001;Build 43
;3.1*11 9.8.04 IHS/ITSC/FCJ added additonal sort by PAT or PO
;3.1*12 11.8.04 IHS/ITSC/FCJ sort by PAT or PO patched
;3.1*25 12.12.15 IHS/OIT/FCJ ADDED VENDOR SUFFIX
;
A ;
S DIC="^AUTTVNDR("
S DIC(0)="AEZQM"
S DIC("A")="Enter Provider/Vendor: "
D ^DIC K DIC
I +Y<1 D K Q
;
S ACHSVDOR=+Y,ACHSIO=IO
I '$D(^ACHSF(DUZ(2),"VB",ACHSVDOR)) W *7,!!,"This vendor has no CHS documents on file.",! W:$$DIR^XBDIR("E","Press <RETURN> To Continue....") "" G A
BDT ;
S ACHSBDT=$$DATE^ACHS("B","DOCUMENTS BY PROVIDER/VENDOR")
I $D(DUOUT)!$D(DTOUT)!(ACHSBDT<1) D K Q
;
EDT ;
S ACHSEDT=$$DATE^ACHS("E","DOCUMENTS BY PROVIDER/VENDOR")
I $D(DTOUT)!(ACHSEDT<1) D K Q
G BDT:$D(DUOUT)
G:$$EBB^ACHS(ACHSBDT,ACHSEDT) EDT
B ;
W !!,"TYPE of service:"
S ACHS("A")=$P($G(^DD(9002080.01,3,0)),U,3)
F ACHS=1:1 S ACHS(ACHS)=$P(ACHS("A"),";",ACHS) Q:ACHS(ACHS)="" W ?20,$P(ACHS(ACHS),":")," ",$P(ACHS(ACHS),":",2),!
W !,"Select TYPE of service (1 - ",ACHS-1," 'A' = 'ALL') ALL // "
D READ^ACHSFU
I $G(ACHSQUIT) D K Q
G BDT:$D(DUOUT)
S:(Y="") Y="A"
G B3:Y="A"
I ($E(Y)="?")!(Y<1)!(Y>(ACHS-1)) W !!,"Enter an 'A' to view documents for all types of service,",!,"otherwise, enter a number from 1 to ",ACHS-1,".",! G B
B3 ;
K ACHSTYPE
S:Y="A" ACHSTYPE="ALL"
I '$D(ACHSTYPE) S ACHSTYPE=+Y
D ;
W !!,"Type of Report:"
W !!,"1 list only PAID documents"
W !,"2 list only OPEN documents"
W !,"3 list only CANCELLED documents"
W !,"4 list ALL documents"
W !,"5 print TOTALS ONLY (no specific documents)",!!
W "list ALL documents// "
D READ^ACHSFU
I $G(ACHSQUIT) D K Q
G B:$D(DUOUT)
S:(Y="") Y=4
I ($E(Y)="?")!(+Y<1)!(+Y>5) W !!,*7,"Enter only '1' through '5'." G D
S ACHSRPT=+Y
;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ ADDED NXT SECT
SORT ;SORT BY PATIENT OR PO
G:ACHSRPT=5 DEV
S DIR(0)="S^1:Purchase Order;2:Patient",DIR("A")="Sort by",DIR("B")=2
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G K Q
DEV ;
S ACHSSRT=Y
;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ END OF CHANGES
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D K Q
I %="B" D VIEWR^XBLM("PRINT^ACHSVDC"),EN^XBVK("VALM"),K Q
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS D K Q
G:'$D(IO("Q")) PRINT
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
S ZTRTN="PRINT^ACHSVDC",ZTDESC="CHS VENDOR Document Summary, "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_" for "_ACHSVDOR
F ACHS="ACHSSRT","ACHSVDOR","ACHSBDT","ACHSRPT","ACHSEDT","ACHSTYPE" S ZTSAVE(ACHS)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ;
K A,ACHS,ACHSIO,ACHSVDOR,ACHSBDT,DTOUT,DUOUT,ACHSEDT,ACHSRPT,ACHSTYPE,ZTSK
D KILL
D ^%ZISC
Q
;
PRINT ;EP - TaskMan.
Q:'$D(^AUTTVNDR(ACHSVDOR))
D FC^ACHSUF
I $D(ACHSERR),ACHSERR=1 G KILL
S (ACHSDOC,ACHSOPEN,ACHSOPEN("$"),ACHSPD,ACHSPD("$"),ACHSCNX,ACHSCNX("$"))=0
S ACHST3=$$C^XBFUNC($S(ACHSRPT=1:"PAID documents only",ACHSRPT=2:"OPEN documents only",ACHSRPT=3:"CANCELLED documents only",1:""),80)
S ACHST1=$$C^XBFUNC($P(^AUTTVNDR(ACHSVDOR,0),U)_" EIN #: "_$P(^AUTTVNDR(ACHSVDOR,11),U),80)_"-"_$P(^AUTTVNDR(ACHSVDOR,11),U,2)
S ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
D BRPT^ACHSFU,HDR
I ACHSRPT<5 S ACHSTOS=$P(^DD(9002080.01,3,0),U,3),ACHSSTS=$P(^DD(9002080.01,11,0),U,3)
DOC ;
S ACHSDOC=$O(^ACHSF(DUZ(2),"VB",ACHSVDOR,ACHSDOC))
;I ACHSDOC="" D END Q ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
I ACHSDOC="",ACHSRPT=5 D END Q ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
I ACHSDOC="" G DOC1 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
S ACHSDOC0=$G(^ACHSF(DUZ(2),"D",ACHSDOC,0))
I ACHSDOC0="" W !!,"NO DOCUMENT ZERO NODE FOR X-REF VB FOR FACILITY: "_DUZ(2)_" DOCUMENT IEN: "_ACHSDOC D KILL Q
G DOC:+$P(ACHSDOC0,U,2)<ACHSBDT,DOC:+$P(ACHSDOC0,U,2)>ACHSEDT,DOC:(ACHSTYPE'="ALL")&(ACHSTYPE'=$P(ACHSDOC0,U,4))
I ACHSRPT<4 S C=$P(ACHSDOC0,U,12) G DOC:ACHSRPT=1&(C'=3),DOC:ACHSRPT=2&(C>2),DOC:ACHSRPT=3&(C'=4)
G RPT5:ACHSRPT=5
;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ START OF CHANGES
S ACHSTYP=$P(ACHSDOC0,U,3)
S X=$S(ACHSTYP=1:"* BLANKET",ACHSTYP=2:"* SPECIAL TRANS",ACHSTYP=0:$P(^DPT($P(^ACHSF(DUZ(2),"D",ACHSDOC,"T",1,0),U,3),0),U),1:"")
S ^TMP($J,"ACHSVDC",ACHSDOC)=X
S ^TMP($J,"ACHSVDC","B",X,ACHSDOC)=""
G DOC
DOC1 S ACHSDOC=0,ACHSPAT=0
I ACHSSRT=1 F S ACHSDOC=$O(^TMP($J,"ACHSVDC",ACHSDOC)) Q:ACHSDOC'?1N.N D DOC2 Q:$G(ACHSQUIT)
I ACHSSRT'=1 F S ACHSPAT=$O(^TMP($J,"ACHSVDC","B",ACHSPAT)) Q:ACHSPAT="" D Q:$G(ACHSQUIT)
.S ACHSDOC=0
.F S ACHSDOC=$O(^TMP($J,"ACHSVDC","B",ACHSPAT,ACHSDOC)) Q:ACHSDOC'?1N.N D DOC2 Q:$G(ACHSQUIT)
I $G(ACHSQUIT) D K Q
D END Q
DOC2 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ END OF CHANGES
S ACHSDOC0=$G(^ACHSF(DUZ(2),"D",ACHSDOC,0))
W !,"DOC. #: ",$P(ACHSDOC0,U,14),"-",ACHSFC,"-",$P(ACHSDOC0,U)," ("
K Y
I $D(^ACHSF(DUZ(2),"D",ACHSDOC,3)),+$P(^(3),U)>0 S Y=+$P(^(3),U)
S:'$D(Y) Y=+$P(ACHSDOC0,U,2)
W $$FMTE^XLFDT(Y),")",?45,"SERVICE: ",$P($P(ACHSTOS,";",$P(ACHSDOC0,U,4)),":",2)
W !?2
S DFN=$P(^ACHSF(DUZ(2),"D",ACHSDOC,"T",1,0),U,3)
I +DFN,$D(^DPT(DFN)) W $P(^DPT(DFN,0),U)
I $P(ACHSDOC0,U,3) W $S($P(ACHSDOC0,U,3)=1:"* BLANKET",$P(ACHSDOC0,U,3)=2:"* SPECIAL TRANS",1:"")
RPT5 ;
W:ACHSRPT<5 ?45
I '$D(^ACHSF(DUZ(2),"D",ACHSDOC,"PA")) G P5
;
S ACHS("$")=$S($D(^ACHSF(DUZ(2),"D",ACHSDOC,"ZA")):+^ACHSF(DUZ(2),"D",ACHSDOC,"ZA"),1:+^ACHSF(DUZ(2),"D",ACHSDOC,"PA"))
I ACHSRPT<5 W "(PAID: " S X=ACHS("$"),X2="2$" D FMT^ACHS W ")"
S ACHSPD=ACHSPD+1,ACHSPD("$")=ACHSPD("$")+ACHS("$")
G P6
;
P5 ;
I $P(ACHSDOC0,U,12)]"",ACHSRPT<5 W "(",$P($P(ACHSSTS,";",$P(ACHSDOC0,U,12)+1),":",2),": "
S ACHS("$")=$S($D(^ACHSF(DUZ(2),"D",ACHSDOC,"ZA")):+^("ZA"),1:$P(ACHSDOC0,U,9))
I $P(ACHSDOC0,U,12)=4 S ACHS("$")=0,A(1)=$O(^ACHSF(DUZ(2),"D",ACHSDOC,"T",0)) F ACHS=0:0 Q:+A(1)=0 S ACHS("$")=+$P(^(A(1),0),U,4),A(1)=$O(^ACHSF(DUZ(2),"D",ACHSDOC,"T",A(1)))
I ACHSRPT<5 S X=ACHS("$"),X2="2$" D FMT^ACHS W ")"
I $P(ACHSDOC0,U,12)=4 S ACHSCNX=ACHSCNX+1,ACHSCNX("$")=ACHSCNX("$")+ACHS("$") G P6
I $P(ACHSDOC0,U,12)<4 S ACHSOPEN=ACHSOPEN+1,ACHSOPEN("$")=ACHSOPEN("$")+ACHS("$")
P6 ;
I ACHSRPT<5 W !,$$REPEAT^XLFSTR("-",79)
I ACHSRPT<5,IOST["C-",$Y>ACHSBM D RTRN^ACHS Q:$G(ACHSQUIT) G KILL:$D(DUOUT)!$D(DTOUT) D HDR
I ACHSRPT<5,IOST'["C-",$Y>ACHSBM D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR
I $G(ACHSQUIT) D KILL
I ACHSRPT=5 G DOC
Q
;
END ;
W !,"Total documents: ",ACHSPD+ACHSCNX+ACHSOPEN,!!
I ACHSPD W "TOTAL PAID DOCUMENTS:",$J(ACHSPD,12),?40,"TOTAL DOLLARS PAID: " S X=ACHSPD("$"),X2="2$",X3=16 D FMT^ACHS W !
I ACHSCNX W "TOTAL CANCELLED DOCUMENTS:",$J(ACHSCNX,7),?40,"TOTAL DOLLARS CANCELLED:" S X=ACHSCNX("$"),X2="2$",X3=16 D FMT^ACHS W !
I ACHSOPEN W "TOTAL OPEN DOCUMENTS:",$J(ACHSOPEN,12),?40,"TOTAL DOLLARS OPEN: " S X=ACHSOPEN("$"),X3=16 D FMT^ACHS W !
D RTRN^ACHS
W @IOF
KILL ;
K A,ACHSCNX,ACHSDOC0,ACHSDOC,ACHSOPEN,ACHSPD,ACHSSTS,ACHSTOS,ACHSTYPE,ACHSVDOR
K ACHSQUIT,ACHSPAT,ACHSSRT,^TMP($J,"ACHSVDC") ;3.1*11 9.8.04 IHS/ITSC/FCJ
D ERPT^ACHS
Q
;
HDR ;
S ACHSPG=ACHSPG+1
W @IOF,!,$$REPEAT^XLFSTR("*",79),!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("PROVIDER-SPECIFIC CHS ACTIVITIES SUMMARY",80),!,ACHST1,!,ACHST2
W:ACHST3]"" !,ACHST3
W !,$$REPEAT^XLFSTR("*",79)
Q
;
ACHSVDC ; IHS/ITSC/PMF - DOCUMENTS BY PROVIDER/VENDOR ; [ 12/23/2004 11:17 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,12,25**;JUN 11, 2001;Build 43
+2 ;3.1*11 9.8.04 IHS/ITSC/FCJ added additonal sort by PAT or PO
+3 ;3.1*12 11.8.04 IHS/ITSC/FCJ sort by PAT or PO patched
+4 ;3.1*25 12.12.15 IHS/OIT/FCJ ADDED VENDOR SUFFIX
+5 ;
A ;
+1 SET DIC="^AUTTVNDR("
+2 SET DIC(0)="AEZQM"
+3 SET DIC("A")="Enter Provider/Vendor: "
+4 DO ^DIC
KILL DIC
+5 IF +Y<1
DO K
QUIT
+6 ;
+7 SET ACHSVDOR=+Y
SET ACHSIO=IO
+8 IF '$DATA(^ACHSF(DUZ(2),"VB",ACHSVDOR))
WRITE *7,!!,"This vendor has no CHS documents on file.",!
IF $$DIR^XBDIR("E","Press <RETURN> To Continue....")
WRITE ""
GOTO A
BDT ;
+1 SET ACHSBDT=$$DATE^ACHS("B","DOCUMENTS BY PROVIDER/VENDOR")
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHSBDT<1)
DO K
QUIT
+3 ;
EDT ;
+1 SET ACHSEDT=$$DATE^ACHS("E","DOCUMENTS BY PROVIDER/VENDOR")
+2 IF $DATA(DTOUT)!(ACHSEDT<1)
DO K
QUIT
+3 IF $DATA(DUOUT)
GOTO BDT
+4 IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO EDT
B ;
+1 WRITE !!,"TYPE of service:"
+2 SET ACHS("A")=$PIECE($GET(^DD(9002080.01,3,0)),U,3)
+3 FOR ACHS=1:1
SET ACHS(ACHS)=$PIECE(ACHS("A"),";",ACHS)
IF ACHS(ACHS)=""
QUIT
WRITE ?20,$PIECE(ACHS(ACHS),":")," ",$PIECE(ACHS(ACHS),":",2),!
+4 WRITE !,"Select TYPE of service (1 - ",ACHS-1," 'A' = 'ALL') ALL // "
+5 DO READ^ACHSFU
+6 IF $GET(ACHSQUIT)
DO K
QUIT
+7 IF $DATA(DUOUT)
GOTO BDT
+8 IF (Y="")
SET Y="A"
+9 IF Y="A"
GOTO B3
+10 IF ($EXTRACT(Y)="?")!(Y<1)!(Y>(ACHS-1))
WRITE !!,"Enter an 'A' to view documents for all types of service,",!,"otherwise, enter a number from 1 to ",ACHS-1,".",!
GOTO B
B3 ;
+1 KILL ACHSTYPE
+2 IF Y="A"
SET ACHSTYPE="ALL"
+3 IF '$DATA(ACHSTYPE)
SET ACHSTYPE=+Y
D ;
+1 WRITE !!,"Type of Report:"
+2 WRITE !!,"1 list only PAID documents"
+3 WRITE !,"2 list only OPEN documents"
+4 WRITE !,"3 list only CANCELLED documents"
+5 WRITE !,"4 list ALL documents"
+6 WRITE !,"5 print TOTALS ONLY (no specific documents)",!!
+7 WRITE "list ALL documents// "
+8 DO READ^ACHSFU
+9 IF $GET(ACHSQUIT)
DO K
QUIT
+10 IF $DATA(DUOUT)
GOTO B
+11 IF (Y="")
SET Y=4
+12 IF ($EXTRACT(Y)="?")!(+Y<1)!(+Y>5)
WRITE !!,*7,"Enter only '1' through '5'."
GOTO D
+13 SET ACHSRPT=+Y
+14 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ ADDED NXT SECT
SORT ;SORT BY PATIENT OR PO
+1 IF ACHSRPT=5
GOTO DEV
+2 SET DIR(0)="S^1:Purchase Order;2:Patient"
SET DIR("A")="Sort by"
SET DIR("B")=2
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO K
QUIT
DEV ;
+1 SET ACHSSRT=Y
+2 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ END OF CHANGES
+3 SET %=$$PB^ACHS
+4 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO K
QUIT
+5 IF %="B"
DO VIEWR^XBLM("PRINT^ACHSVDC")
DO EN^XBVK("VALM")
DO K
QUIT
+6 SET %ZIS="OPQ"
+7 DO ^%ZIS
+8 IF POP
DO HOME^%ZIS
DO K
QUIT
+9 IF '$DATA(IO("Q"))
GOTO PRINT
+10 KILL IO("Q")
+11 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+12 SET ZTRTN="PRINT^ACHSVDC"
SET ZTDESC="CHS VENDOR Document Summary, "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_" for "_ACHSVDOR
+13 FOR ACHS="ACHSSRT","ACHSVDOR","ACHSBDT","ACHSRPT","ACHSEDT","ACHSTYPE"
SET ZTSAVE(ACHS)=""
+14 DO ^%ZTLOAD
+15 IF '$DATA(ZTSK)
GOTO DEV
K ;
+1 KILL A,ACHS,ACHSIO,ACHSVDOR,ACHSBDT,DTOUT,DUOUT,ACHSEDT,ACHSRPT,ACHSTYPE,ZTSK
+2 DO KILL
+3 DO ^%ZISC
+4 QUIT
+5 ;
PRINT ;EP - TaskMan.
+1 IF '$DATA(^AUTTVNDR(ACHSVDOR))
QUIT
+2 DO FC^ACHSUF
+3 IF $DATA(ACHSERR)
IF ACHSERR=1
GOTO KILL
+4 SET (ACHSDOC,ACHSOPEN,ACHSOPEN("$"),ACHSPD,ACHSPD("$"),ACHSCNX,ACHSCNX("$"))=0
+5 SET ACHST3=$$C^XBFUNC($SELECT(ACHSRPT=1:"PAID documents only",ACHSRPT=2:"OPEN documents only",ACHSRPT=3:"CANCELLED documents only",1:""),80)
+6 SET ACHST1=$$C^XBFUNC($PIECE(^AUTTVNDR(ACHSVDOR,0),U)_" EIN #: "_$PIECE(^AUTTVNDR(ACHSVDOR,11),U),80)_"-"_$PIECE(^AUTTVNDR(ACHSVDOR,11),U,2)
+7 SET ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
+8 DO BRPT^ACHSFU
DO HDR
+9 IF ACHSRPT<5
SET ACHSTOS=$PIECE(^DD(9002080.01,3,0),U,3)
SET ACHSSTS=$PIECE(^DD(9002080.01,11,0),U,3)
DOC ;
+1 SET ACHSDOC=$ORDER(^ACHSF(DUZ(2),"VB",ACHSVDOR,ACHSDOC))
+2 ;I ACHSDOC="" D END Q ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
+3 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
IF ACHSDOC=""
IF ACHSRPT=5
DO END
QUIT
+4 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ
IF ACHSDOC=""
GOTO DOC1
+5 SET ACHSDOC0=$GET(^ACHSF(DUZ(2),"D",ACHSDOC,0))
+6 IF ACHSDOC0=""
WRITE !!,"NO DOCUMENT ZERO NODE FOR X-REF VB FOR FACILITY: "_DUZ(2)_" DOCUMENT IEN: "_ACHSDOC
DO KILL
QUIT
+7 IF +$PIECE(ACHSDOC0,U,2)<ACHSBDT
GOTO DOC
IF +$PIECE(ACHSDOC0,U,2)>ACHSEDT
GOTO DOC
IF (ACHSTYPE'="ALL")&(ACHSTYPE'=$PIECE(ACHSDOC0,U,4))
GOTO DOC
+8 IF ACHSRPT<4
SET C=$PIECE(ACHSDOC0,U,12)
IF ACHSRPT=1&(C'=3)
GOTO DOC
IF ACHSRPT=2&(C>2)
GOTO DOC
IF ACHSRPT=3&(C'=4)
GOTO DOC
+9 IF ACHSRPT=5
GOTO RPT5
+10 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ START OF CHANGES
+11 SET ACHSTYP=$PIECE(ACHSDOC0,U,3)
+12 SET X=$SELECT(ACHSTYP=1:"* BLANKET",ACHSTYP=2:"* SPECIAL TRANS",ACHSTYP=0:$PIECE(^DPT($PIECE(^ACHSF(DUZ(2),"D",ACHSDOC,"T",1,0),U,3),0),U),1:"")
+13 SET ^TMP($JOB,"ACHSVDC",ACHSDOC)=X
+14 SET ^TMP($JOB,"ACHSVDC","B",X,ACHSDOC)=""
+15 GOTO DOC
DOC1 SET ACHSDOC=0
SET ACHSPAT=0
+1 IF ACHSSRT=1
FOR
SET ACHSDOC=$ORDER(^TMP($JOB,"ACHSVDC",ACHSDOC))
IF ACHSDOC'?1N.N
QUIT
DO DOC2
IF $GET(ACHSQUIT)
QUIT
+2 IF ACHSSRT'=1
FOR
SET ACHSPAT=$ORDER(^TMP($JOB,"ACHSVDC","B",ACHSPAT))
IF ACHSPAT=""
QUIT
Begin DoDot:1
+3 SET ACHSDOC=0
+4 FOR
SET ACHSDOC=$ORDER(^TMP($JOB,"ACHSVDC","B",ACHSPAT,ACHSDOC))
IF ACHSDOC'?1N.N
QUIT
DO DOC2
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+5 IF $GET(ACHSQUIT)
DO K
QUIT
+6 DO END
QUIT
DOC2 ;ACHS*3.1*11 9.8.04 IHS/ITSC/FCJ END OF CHANGES
+1 SET ACHSDOC0=$GET(^ACHSF(DUZ(2),"D",ACHSDOC,0))
+2 WRITE !,"DOC. #: ",$PIECE(ACHSDOC0,U,14),"-",ACHSFC,"-",$PIECE(ACHSDOC0,U)," ("
+3 KILL Y
+4 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDOC,3))
IF +$PIECE(^(3),U)>0
SET Y=+$PIECE(^(3),U)
+5 IF '$DATA(Y)
SET Y=+$PIECE(ACHSDOC0,U,2)
+6 WRITE $$FMTE^XLFDT(Y),")",?45,"SERVICE: ",$PIECE($PIECE(ACHSTOS,";",$PIECE(ACHSDOC0,U,4)),":",2)
+7 WRITE !?2
+8 SET DFN=$PIECE(^ACHSF(DUZ(2),"D",ACHSDOC,"T",1,0),U,3)
+9 IF +DFN
IF $DATA(^DPT(DFN))
WRITE $PIECE(^DPT(DFN,0),U)
+10 IF $PIECE(ACHSDOC0,U,3)
WRITE $SELECT($PIECE(ACHSDOC0,U,3)=1:"* BLANKET",$PIECE(ACHSDOC0,U,3)=2:"* SPECIAL TRANS",1:"")
RPT5 ;
+1 IF ACHSRPT<5
WRITE ?45
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDOC,"PA"))
GOTO P5
+3 ;
+4 SET ACHS("$")=$SELECT($DATA(^ACHSF(DUZ(2),"D",ACHSDOC,"ZA")):+^ACHSF(DUZ(2),"D",ACHSDOC,"ZA"),1:+^ACHSF(DUZ(2),"D",ACHSDOC,"PA"))
+5 IF ACHSRPT<5
WRITE "(PAID: "
SET X=ACHS("$")
SET X2="2$"
DO FMT^ACHS
WRITE ")"
+6 SET ACHSPD=ACHSPD+1
SET ACHSPD("$")=ACHSPD("$")+ACHS("$")
+7 GOTO P6
+8 ;
P5 ;
+1 IF $PIECE(ACHSDOC0,U,12)]""
IF ACHSRPT<5
WRITE "(",$PIECE($PIECE(ACHSSTS,";",$PIECE(ACHSDOC0,U,12)+1),":",2),": "
+2 SET ACHS("$")=$SELECT($DATA(^ACHSF(DUZ(2),"D",ACHSDOC,"ZA")):+^("ZA"),1:$PIECE(ACHSDOC0,U,9))
+3 IF $PIECE(ACHSDOC0,U,12)=4
SET ACHS("$")=0
SET A(1)=$ORDER(^ACHSF(DUZ(2),"D",ACHSDOC,"T",0))
FOR ACHS=0:0
IF +A(1)=0
QUIT
SET ACHS("$")=+$PIECE(^(A(1),0),U,4)
SET A(1)=$ORDER(^ACHSF(DUZ(2),"D",ACHSDOC,"T",A(1)))
+4 IF ACHSRPT<5
SET X=ACHS("$")
SET X2="2$"
DO FMT^ACHS
WRITE ")"
+5 IF $PIECE(ACHSDOC0,U,12)=4
SET ACHSCNX=ACHSCNX+1
SET ACHSCNX("$")=ACHSCNX("$")+ACHS("$")
GOTO P6
+6 IF $PIECE(ACHSDOC0,U,12)<4
SET ACHSOPEN=ACHSOPEN+1
SET ACHSOPEN("$")=ACHSOPEN("$")+ACHS("$")
P6 ;
+1 IF ACHSRPT<5
WRITE !,$$REPEAT^XLFSTR("-",79)
+2 IF ACHSRPT<5
IF IOST["C-"
IF $Y>ACHSBM
DO RTRN^ACHS
IF $GET(ACHSQUIT)
QUIT
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO KILL
DO HDR
+3 IF ACHSRPT<5
IF IOST'["C-"
IF $Y>ACHSBM
DO RTRN^ACHS
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO KILL
DO HDR
+4 IF $GET(ACHSQUIT)
DO KILL
+5 IF ACHSRPT=5
GOTO DOC
+6 QUIT
+7 ;
END ;
+1 WRITE !,"Total documents: ",ACHSPD+ACHSCNX+ACHSOPEN,!!
+2 IF ACHSPD
WRITE "TOTAL PAID DOCUMENTS:",$JUSTIFY(ACHSPD,12),?40,"TOTAL DOLLARS PAID: "
SET X=ACHSPD("$")
SET X2="2$"
SET X3=16
DO FMT^ACHS
WRITE !
+3 IF ACHSCNX
WRITE "TOTAL CANCELLED DOCUMENTS:",$JUSTIFY(ACHSCNX,7),?40,"TOTAL DOLLARS CANCELLED:"
SET X=ACHSCNX("$")
SET X2="2$"
SET X3=16
DO FMT^ACHS
WRITE !
+4 IF ACHSOPEN
WRITE "TOTAL OPEN DOCUMENTS:",$JUSTIFY(ACHSOPEN,12),?40,"TOTAL DOLLARS OPEN: "
SET X=ACHSOPEN("$")
SET X3=16
DO FMT^ACHS
WRITE !
+5 DO RTRN^ACHS
+6 WRITE @IOF
KILL ;
+1 KILL A,ACHSCNX,ACHSDOC0,ACHSDOC,ACHSOPEN,ACHSPD,ACHSSTS,ACHSTOS,ACHSTYPE,ACHSVDOR
+2 ;3.1*11 9.8.04 IHS/ITSC/FCJ
KILL ACHSQUIT,ACHSPAT,ACHSSRT,^TMP($JOB,"ACHSVDC")
+3 DO ERPT^ACHS
+4 QUIT
+5 ;
HDR ;
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!,$$REPEAT^XLFSTR("*",79),!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("PROVIDER-SPECIFIC CHS ACTIVITIES SUMMARY",80),!,ACHST1,!,ACHST2
+3 IF ACHST3]""
WRITE !,ACHST3
+4 WRITE !,$$REPEAT^XLFSTR("*",79)
+5 QUIT
+6 ;
