ACHSDSTE ; IHS/OIT/FCJ - DOCUMENT STATUS REPORT FOR EOBR DATA ; [ 01/16/2003 8:54 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**26**;JUN 11, 2001;Build 43
;ACHS*3.1*26 NEW ROUTINE
;Modified routine to just print documents that have had payments
;between a specific data range. This report if for aiding in service
;units monthly reconciliation.
;
;
D ^ACHSVAR
TITLE ;;DOCUMENT STATUS
S ACHSIO=IO
K X2,X3
BDT ;
S ACHSBDT=$$DATE^ACHS("B",$P($T(TITLE),";",3),"ISSUE")
G K:$D(DUOUT)!$D(DTOUT)!(ACHSBDT<1)
EDT ;
S ACHSEDT=$$DATE^ACHS("E",$P($T(TITLE),";",3),"ISSUE")
G K:$D(DTOUT)!(ACHSEDT<1),BDT:$D(DUOUT)
G:$$EBB^ACHS(ACHSBDT,ACHSEDT) EDT
FY ;
W !!,"Enter Fiscal (e.g. 2016): " D READ^ACHSFU Q:$D(DUOUT)!$D(DTOUT) I Y'?4N W !!,*7,"Enter 4 DIGIT Fiscal Year" G FY
S FY=$E(Y,4),ACHSFY=$E(Y,3,4)
;
W !!!,"ONLY DOCUMENTS THAT HAVE HAD PAYMENTS WILL BE LISTED (P/IP/ZA)"
W !!
;
DEV ;
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS G K
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^ACHSDSTE",ZTIO="",ZTDESC="CHS PAYMENTS",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
F ACHS="ACHSQIO","ACHSBDT","ACHSEDT","ACHSRPT","ACHSFY","FY" S ZTSAVE(ACHS)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ;
K ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK,ACHSFY,FY
D ^%ZISC
Q
;
PRINT ;EP - From TaskMan.
;
D FC^ACHSUF
I $D(ACHSERR),ACHSERR=1 K ZTSK G KILL
S (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0
S ACHST1=$$C^XBFUNC("PAYMENTS",80),ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
D BRPT^ACHSFU
D HDR
S X3=0,ACHSBDT=ACHSBDT-1
A ; Main loop.
F S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT)) Q:(ACHSBDT'?1N.N)!(ACHSBDT>ACHSEDT) D Q:$D(QFLG)
.S ACHSTYPE=0 F S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE)) Q:ACHSTYPE="" D Q:$D(QFLG)
..I (ACHSTYPE'["P"),(ACHSTYPE'="ZA") Q
..S DA=0 F S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA)) Q:DA="" D Q:$D(QFLG)
...Q:'$D(^ACHSF(DUZ(2),"D",DA,0))
...Q:FY'=$P(^ACHSF(DUZ(2),"D",DA,0),U,14)
...S ACHSDOC1=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSVPTR=$P(^(0),U,8),ACHSDOC2=$P(^(0),U,14),ACHSTOS=$P(^(0),U,4),ACHSBLNK=+$P(^(0),U,3)
...Q:(ACHSVPTR']"")!('$D(^AUTTVNDR(ACHSVPTR,0)))
...S ACHSVNDR=$P(^AUTTVNDR(ACHSVPTR,0),U)
...S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
...S TXN=0 F S TXN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA,TXN)) Q:TXN="" D Q:$D(QFLG)
....S ACHSTXN=^ACHSF(DUZ(2),"D",DA,"T",TXN,0)
....S DFN=$P(ACHSTXN,U,3) I +DFN>0,$D(^DPT(DFN,0)) S ACHSNAME=$P(^(0),U)
....I '$D(ACHSNAME),ACHSBLNK S ACHSNAME=$S(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")
....S ACHSTXDT=$P(ACHSTXN,U,1)
....S ACHSTXTP=$P(ACHSTXN,U,2)
....S ACHSTXAM=$P(ACHSTXN,U,4)
....S ACHSPMTP=$P(ACHSTXN,U,5)
....S ACHSEOBR=$P(ACHSTXN,U,13)
....W $E(ACHSNAME,1,24),?25,$E(ACHSVNDR,1,26),?52,$E(ACHSTXDT,4,5)_"/"_$E(ACHSTXDT,6,7)_"/"_$E(ACHSTXDT,2,3)
....W ?66
....W ACHSTXTP
....S X=ACHSTXAM
....D COMMA^%DTC
....W ?80-$L(X),X
....W !,ACHSDOC,?25,$S(ACHSTOS=1:"HOSPITAL",ACHSTOS=2:"DENTAL",ACHSTOS=3:"OUTPATIENT",1:""),?52,$E(ACHSEOBR,4,5)_"/"_$E(ACHSEOBR,6,7)_"/"_$E(ACHSEOBR,2,3)
....S ACHSTOTP=ACHSTOTP+1,ACHSTOTP("$")=ACHSTOTP("$")+ACHSTXAM
....W !!
....I $Y>ACHSBM D CHECK Q:$D(QFLG) D HDR
;
END ; Print totals, ask RTRN, write IOF.
W !,$$REPEAT^XLFSTR("-",79),!
S X2="2$",X3=14
I ACHSTOTP S X=ACHSTOTP("$") D COMMA^%DTC W "TOTAL PAID DOCUMENTS:",$J(ACHSTOTP,11),?40,"TOTAL DOLLARS PAID: ",X,!
D CHECK Q:$D(QFLG)
W @IOF
KILL ; Do ERPT, kill vars, quit.
I $D(ZTQUEUED) K ACHSFC
D ERPT^ACHS
K ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,ACHSTXN,ACHSTXDT,ACHSTXTP,ACHSTXAM,ACHSPMTP,ACHSEOBR
K DA,DFN,X2,X3,TXN,FY
Q
;
HDR ; Print report header.
S ACHSPG=ACHSPG+1
W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?25,"DOCUMENT STATUS REPORT"_" - "_"FY-"_ACHSFY
W !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Patient Name",?25,"Provider of Service",?52,"Trans Date",?64,"Status",?73,"Amount",!,"Document Number",?25,"Type",?52,"EOBR Date"
W !,$$REPEAT^XLFSTR("=",79),!
Q
;
CHECK ;Check for Quit
Q:$D(IO("S"))
Q:$D(ZTQUEUED)
K QFLG
K DIR
S DIR(0)="E"
D ^DIR
I ($D(DTOUT))!($D(DUOUT)) S QFLG=1
Q
ACHSDSTE ; IHS/OIT/FCJ - DOCUMENT STATUS REPORT FOR EOBR DATA ; [ 01/16/2003 8:54 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**26**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*26 NEW ROUTINE
+3 ;Modified routine to just print documents that have had payments
+4 ;between a specific data range. This report if for aiding in service
+5 ;units monthly reconciliation.
+6 ;
+7 ;
+8 DO ^ACHSVAR
TITLE ;;DOCUMENT STATUS
+1 SET ACHSIO=IO
+2 KILL X2,X3
BDT ;
+1 SET ACHSBDT=$$DATE^ACHS("B",$PIECE($TEXT(TITLE),";",3),"ISSUE")
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHSBDT<1)
GOTO K
EDT ;
+1 SET ACHSEDT=$$DATE^ACHS("E",$PIECE($TEXT(TITLE),";",3),"ISSUE")
+2 IF $DATA(DTOUT)!(ACHSEDT<1)
GOTO K
IF $DATA(DUOUT)
GOTO BDT
+3 IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO EDT
FY ;
+1 WRITE !!,"Enter Fiscal (e.g. 2016): "
DO READ^ACHSFU
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
IF Y'?4N
WRITE !!,*7,"Enter 4 DIGIT Fiscal Year"
GOTO FY
+2 SET FY=$EXTRACT(Y,4)
SET ACHSFY=$EXTRACT(Y,3,4)
+3 ;
+4 WRITE !!!,"ONLY DOCUMENTS THAT HAVE HAD PAYMENTS WILL BE LISTED (P/IP/ZA)"
+5 WRITE !!
+6 ;
DEV ;
+1 SET %ZIS="OPQ"
+2 DO ^%ZIS
+3 IF POP
DO HOME^%ZIS
GOTO K
+4 IF '$DATA(IO("Q"))
GOTO PRINT
+5 KILL IO("Q")
+6 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+7 SET ZTRTN="PRINT^ACHSDSTE"
SET ZTIO=""
SET ZTDESC="CHS PAYMENTS"
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+8 FOR ACHS="ACHSQIO","ACHSBDT","ACHSEDT","ACHSRPT","ACHSFY","FY"
SET ZTSAVE(ACHS)=""
+9 DO ^%ZTLOAD
+10 IF '$DATA(ZTSK)
GOTO DEV
K ;
+1 KILL ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK,ACHSFY,FY
+2 DO ^%ZISC
+3 QUIT
+4 ;
PRINT ;EP - From TaskMan.
+1 ;
+2 DO FC^ACHSUF
+3 IF $DATA(ACHSERR)
IF ACHSERR=1
KILL ZTSK
GOTO KILL
+4 SET (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0
+5 SET ACHST1=$$C^XBFUNC("PAYMENTS",80)
SET ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
+6 DO BRPT^ACHSFU
+7 DO HDR
+8 SET X3=0
SET ACHSBDT=ACHSBDT-1
A ; Main loop.
+1 FOR
SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT))
IF (ACHSBDT'?1N.N)!(ACHSBDT>ACHSEDT)
QUIT
Begin DoDot:1
+2 SET ACHSTYPE=0
FOR
SET ACHSTYPE=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE))
IF ACHSTYPE=""
QUIT
Begin DoDot:2
+3 IF (ACHSTYPE'["P")
IF (ACHSTYPE'="ZA")
QUIT
+4 SET DA=0
FOR
SET DA=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA))
IF DA=""
QUIT
Begin DoDot:3
+5 IF '$DATA(^ACHSF(DUZ(2),"D",DA,0))
QUIT
+6 IF FY'=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,14)
QUIT
+7 SET ACHSDOC1=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U)
SET ACHSVPTR=$PIECE(^(0),U,8)
SET ACHSDOC2=$PIECE(^(0),U,14)
SET ACHSTOS=$PIECE(^(0),U,4)
SET ACHSBLNK=+$PIECE(^(0),U,3)
+8 IF (ACHSVPTR']"")!('$DATA(^AUTTVNDR(ACHSVPTR,0)))
QUIT
+9 SET ACHSVNDR=$PIECE(^AUTTVNDR(ACHSVPTR,0),U)
+10 SET ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
+11 SET TXN=0
FOR
SET TXN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA,TXN))
IF TXN=""
QUIT
Begin DoDot:4
+12 SET ACHSTXN=^ACHSF(DUZ(2),"D",DA,"T",TXN,0)
+13 SET DFN=$PIECE(ACHSTXN,U,3)
IF +DFN>0
IF $DATA(^DPT(DFN,0))
SET ACHSNAME=$PIECE(^(0),U)
+14 IF '$DATA(ACHSNAME)
IF ACHSBLNK
SET ACHSNAME=$SELECT(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")
+15 SET ACHSTXDT=$PIECE(ACHSTXN,U,1)
+16 SET ACHSTXTP=$PIECE(ACHSTXN,U,2)
+17 SET ACHSTXAM=$PIECE(ACHSTXN,U,4)
+18 SET ACHSPMTP=$PIECE(ACHSTXN,U,5)
+19 SET ACHSEOBR=$PIECE(ACHSTXN,U,13)
+20 WRITE $EXTRACT(ACHSNAME,1,24),?25,$EXTRACT(ACHSVNDR,1,26),?52,$EXTRACT(ACHSTXDT,4,5)_"/"_$EXTRACT(ACHSTXDT,6,7)_"/"_$EXTRACT(ACHSTXDT,2,3)
+21 WRITE ?66
+22 WRITE ACHSTXTP
+23 SET X=ACHSTXAM
+24 DO COMMA^%DTC
+25 WRITE ?80-$LENGTH(X),X
+26 WRITE !,ACHSDOC,?25,$SELECT(ACHSTOS=1:"HOSPITAL",ACHSTOS=2:"DENTAL",ACHSTOS=3:"OUTPATIENT",1:""),?52,$EXTRACT(ACHSEOBR,4,5)_"/"_$EXTRACT(ACHSEOBR,6,7)_"/"_$EXTRACT(ACHSEOBR,2,3)
+27 SET ACHSTOTP=ACHSTOTP+1
SET ACHSTOTP("$")=ACHSTOTP("$")+ACHSTXAM
+28 WRITE !!
+29 IF $Y>ACHSBM
DO CHECK
IF $DATA(QFLG)
QUIT
DO HDR
End DoDot:4
IF $DATA(QFLG)
QUIT
End DoDot:3
IF $DATA(QFLG)
QUIT
End DoDot:2
IF $DATA(QFLG)
QUIT
End DoDot:1
IF $DATA(QFLG)
QUIT
+30 ;
END ; Print totals, ask RTRN, write IOF.
+1 WRITE !,$$REPEAT^XLFSTR("-",79),!
+2 SET X2="2$"
SET X3=14
+3 IF ACHSTOTP
SET X=ACHSTOTP("$")
DO COMMA^%DTC
WRITE "TOTAL PAID DOCUMENTS:",$JUSTIFY(ACHSTOTP,11),?40,"TOTAL DOLLARS PAID: ",X,!
+4 DO CHECK
IF $DATA(QFLG)
QUIT
+5 WRITE @IOF
KILL ; Do ERPT, kill vars, quit.
+1 IF $DATA(ZTQUEUED)
KILL ACHSFC
+2 DO ERPT^ACHS
+3 KILL ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,ACHSTXN,ACHSTXDT,ACHSTXTP,ACHSTXAM,ACHSPMTP,ACHSEOBR
+4 KILL DA,DFN,X2,X3,TXN,FY
+5 QUIT
+6 ;
HDR ; Print report header.
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?25,"DOCUMENT STATUS REPORT"_" - "_"FY-"_ACHSFY
+3 WRITE !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Patient Name",?25,"Provider of Service",?52,"Trans Date",?64,"Status",?73,"Amount",!,"Document Number",?25,"Type",?52,"EOBR Date"
+4 WRITE !,$$REPEAT^XLFSTR("=",79),!
+5 QUIT
+6 ;
CHECK ;Check for Quit
+1 IF $DATA(IO("S"))
QUIT
+2 IF $DATA(ZTQUEUED)
QUIT
+3 KILL QFLG
+4 KILL DIR
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET QFLG=1
+8 QUIT
