- 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
