Routine: ACHSRGPR

ACHSRGPR ;IHS/OIT/FCJ - GPRA REPORT DOS VS DATE PO ISS

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

 ;Auth end DOS used, if not available then Auth Beg DOS

ST ;

 S ACHSIO=IO

 W !!,"This is a GPRA report to calculate the days between the Date of Service"

 W !,"and when the Purchase Order was issued. Date of Service is the estimated"

 W !,"End Date of Service, even if the document has been paid."

 W !!,"The Purchase Order will either be selected by Fiscal Year or the Date of"

 W !,"Service to fall within the Fiscal year Beginning and Ending date."

 W !!,"The report is selected and sorted by issue date."

FY ; Select FY.

 S ACHSACFY=$$FYSEL^ACHS(1)

 G:$D(DTOUT)!$D(DUOUT) EXT

 I '$D(^ACHS(9,DUZ(2),"FY",ACHSACFY)) W !!,*7,"Fiscal year '",ACHSACFY,"' does not exist. -- TRY AGAIN" G FY

FYDT ;BEG AND END DATES FOR THE FY, DOS >ACHSBFY OR <ACHSEFY

 I $P(^ACHSF(DUZ(2),0),U,7)=1 S ACHSBFY=ACHSACFY-1701_($P(^ACHSF(DUZ(2),0),U,6)-1),ACHSEFY=ACHSACFY-1700_($P(^ACHSF(DUZ(2),0),U,6)-1)

 E  S ACHSBFY=ACHSACFY-1700_($P(^ACHSF(DUZ(2),0),U,6)-1),ACHSEFY=ACHSACFY-1699_($P(^ACHSF(DUZ(2),0),U,6)-1)

BDT ; Enter beginning date.

 S ACHSBDT=$$DATE^ACHS("B","GPRA","")

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

EDT ; Enter the ending date.

 S ACHSEDT=$$DATE^ACHS("E","GPRA","")

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

DOS ; REPORT BY DOS WITHIN FY OR FY

 ; Enter FY or DOS

 S ACHSRTYD="F"

 S DIR(0)="S^F:Fiscal Year;D:Date of Service",DIR("B")="Fiscal Year",DIR("A")="Report PO's by "

 S DIR("?")="Report PO's by FY or by Date of service for sites that move money forward into one FY account."

 D ^DIR

 G EXT:$D(DUOUT),EXT:$D(DTOUT),EXT:$D(DIROUT)

 S ACHSRTYD=Y

TYPE ; TYPE OF REPORT SUMARRY OR DETAILED

 ; Enter Summary or Detail

 S DIR(0)="S^S:SUMMARY;D:DETAILED",DIR("A")="Report Type ",DIR("B")="SUMMARY"

 S DIR("?")="Detail will display indiviual PO, Summary will display only the totals"

 D ^DIR

 G EXT:$D(DUOUT),EXT:$D(DTOUT),EXT:$D(DIROUT)

 S ACHSRTYP=Y

DEV ; Select device for report.

W !

 S %=$$PB^ACHS

 I %=U!$D(DTOUT)!$D(DUOUT) G EXT

 I %="B" D VIEWR^XBLM("CALC^ACHSRGPR"),EN^XBVK("VALM") G EXT

 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 EXT

 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^ACHSRGPR",ZTDESC="CHS GPRA Report, "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)

 F %="ACHSQIO","ACHSBDT","ACHSEDT","ACHSRTYP","ACHSACFY","ACHSEFY","ACHSBFY","ACHSRTYD" S ZTSAVE(%)=""

 D ^%ZTLOAD

 G:'$D(ZTSK) DEV

 ;end of interactive portion.  The rest performed by Taskman

CALC ;EP - TaskMan.

 D FC^ACHSUF

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

 S ACHSTRDT=ACHSBDT-1

 K ^TMP("ACHSRGPR",$J)

 S (^TMP("ACHSRGPR",$J,"TOTDOC"),^TMP("ACHSRGPR",$J,"TOTPDOC"),^TMP("ACHSRGPR",$J,"TOTADOC"))=0

 S (^TMP("ACHSRGPR",$J,"TOTDAY"),^TMP("ACHSRGPR",$J,"TOTPDAY"),^TMP("ACHSRGPR",$J,"TOTADAY"))=0

TRDT ; Loop thru transaction date x-ref.

 F  S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT)) Q:(ACHSTRDT>ACHSEDT)!(ACHSTRDT'?1N.N)  D

 .; Loop thru transaction type

 .S ACHSTYPE=""

 .F  S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE)) Q:ACHSTYPE=""  D

 ..Q:ACHSTYPE'="I"

 ..S DA=0

 ..F  S DA=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE,DA)) Q:DA'?1N.N  D

 ...Q:('$D(^ACHSF(DUZ(2),"D",DA,0)))!($P(^ACHSF(DUZ(2),"D",DA,0),U,12)=4)   ;QUIT IF CANCELLED

 ...I ACHSRTYD="F" Q:ACHSACFY'=$P(^ACHSF(DUZ(2),"D",DA,0),U,27)   ;IF REPORT BY FY TEST FOR FY

 ...S ACHSDOCN=$P(^ACHSF(DUZ(2),"D",DA,0),U),(X1,ACHSORDT)=$P(^(0),U,2)

 ...D DOSDT

 ...;S (X2,ACHSEDOS)=$S($P(^ACHSF(DUZ(2),"D",DA,3),U,2)'="":$P(^ACHSF(DUZ(2),"D",DA,3),U,2),1:$P(^ACHSF(DUZ(2),"D",DA,3),U))

 ...I ACHSRTYD="D" Q:(ACHSEDOS<ACHSBFY)!(ACHSEDOS>ACHSEFY)   ;IF REPORT BY DOS TEST FOR DOS

 ...D ^%DTC

 ...S ACHSORDT=$E(ACHSORDT,4,5)_"/"_$E(ACHSORDT,6,7)_"/"_$E(ACHSORDT,2,3)

 ...S ACHSEDOS=$E(ACHSEDOS,4,5)_"/"_$E(ACHSEDOS,6,7)_"/"_$E(ACHSEDOS,2,3)

 ...I ACHSRTYP="D" D

 ....S ^TMP("ACHSRGPR",$J,ACHSDOCN)=$E(ACHSACFY,3,4)_"-"_ACHSFC_"-"_ACHSDOCN_U_ACHSEDOS_U_ACHSORDT

 ....I X>0 S $P(^TMP("ACHSRGPR",$J,ACHSDOCN),U,5)=X

 ....E  S $P(^TMP("ACHSRGPR",$J,ACHSDOCN),U,4)=$FN(X,"-")

 ...I X>0 S ^TMP("ACHSRGPR",$J,"TOTADAY")=^TMP("ACHSRGPR",$J,"TOTADAY")+X,^("TOTADOC")=^("TOTADOC")+1

 ...E  S ^TMP("ACHSRGPR",$J,"TOTPDAY")=^TMP("ACHSRGPR",$J,"TOTPDAY")+$FN(X,"-"),^("TOTPDOC")=^("TOTPDOC")+1

 ...S ^TMP("ACHSRGPR",$J,"TOTDOC")=^TMP("ACHSRGPR",$J,"TOTDOC")+1

 ...S ^TMP("ACHSRGPR",$J,"TOTDAY")=^TMP("ACHSRGPR",$J,"TOTDAY")+X

 D PRINT

EXT ; Kill vars, close device, quit.

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

 E  D ^%ZISC

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

 K ^TMP("ACHSRGPR",$J)

 K DTOUT,DUOUT,ZTSK

DOSDT ;FIND THE DOS TO USE

 ;TEST FOR PAID DOCUMENT, USE ACT DOS OR EST EDOS IF NOT DEFINED USE EST BEG DOS

 S X2=""

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

 .S T=0 F  S T=$O(^ACHSF(DUZ(2),"D",DA,"T",T)) Q:T'?1N.N  I $P(^ACHSF(DUZ(2),"D",DA,"T",T,0),U,2)="P" S (X2,ACHSEDOS)=$P(^(0),U,10) Q

 I X2="" S (X2,ACHSEDOS)=$S($P(^ACHSF(DUZ(2),"D",DA,3),U,2)'="":$P(^ACHSF(DUZ(2),"D",DA,3),U,2),1:$P(^ACHSF(DUZ(2),"D",DA,3),U)) ;EDOS="" use EST Beg DOS

PRINT ;

 S ACHSVNDR="",ACHST1=$$C^XBFUNC("GPRA REPORT-AVERAGE DAYS BETWEEN PO ISSUE AND DOS")

 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:ACHSRTYP="D" HDR,DET

 S ACHSRTYP="S" D HDR,SUM

 G EXT Q

DET ;DETAILED REPORT

 S ACHSDOCN=""

 F  S ACHSDOCN=$O(^TMP("ACHSRGPR",$J,ACHSDOCN)) Q:ACHSDOCN'?1N.N  D  Q:$D(DUOUT)!$D(DTOUT)

 .W !,$P(^TMP("ACHSRGPR",$J,ACHSDOCN),U),?19,$P(^(ACHSDOCN),U,2),?35,$P(^(ACHSDOCN),U,3),?51,$J($P(^(ACHSDOCN),U,4),5),?65,$J($P(^(ACHSDOCN),U,5),5)

 .I $Y>ACHSBM D RTRN^ACHS Q:$D(DUOUT)!$D(DTOUT)  D HDR

SUM ;SUMMARY REPORT

 W !!,"TOTAL Documents:  ",$J(^TMP("ACHSRGPR",$J,"TOTDOC"),10)

 W !,"TOTAL Days: ",?18,$J(^TMP("ACHSRGPR",$J,"TOTDAY"),10)

 S ACHSAVG=0

 I ^TMP("ACHSRGPR",$J,"TOTDOC") S ACHSAVG=$S(^TMP("ACHSRGPR",$J,"TOTDOC")>0:^TMP("ACHSRGPR",$J,"TOTDAY")/^TMP("ACHSRGPR",$J,"TOTDOC"),1:0)

 W !,"Average Days: ",?18,$J(ACHSAVG,10,2),!

 W !!,"TOTAL Documents Prior or = to DOS:  ",?37,$J(^TMP("ACHSRGPR",$J,"TOTPDOC"),10)

 W !,"TOTAL Days for Prior or = to DOS: ",?37,$J(^TMP("ACHSRGPR",$J,"TOTPDAY"),10)

 S ACHSAVG=0

 I ^TMP("ACHSRGPR",$J,"TOTPDOC")>0 S ACHSAVG=$S(^TMP("ACHSRGPR",$J,"TOTDOC")>0:^TMP("ACHSRGPR",$J,"TOTPDAY")/^TMP("ACHSRGPR",$J,"TOTPDOC"),1:0)

 W !,"Average Days Prior or = to DOS: ",?37,$J(ACHSAVG,10,2),!

 W !!,"TOTAL Documents After DOS:  ",?28,$J(^TMP("ACHSRGPR",$J,"TOTADOC"),10)

 W !,"TOTAL Days After DOS: ",?28,$J(^TMP("ACHSRGPR",$J,"TOTADAY"),10)

 S ACHSAVG=0

 I ^TMP("ACHSRGPR",$J,"TOTADOC"),1>0 S ACHSAVG=$S(^TMP("ACHSRGPR",$J,"TOTDOC")>0:^TMP("ACHSRGPR",$J,"TOTADAY")/^TMP("ACHSRGPR",$J,"TOTADOC"),1:0)

 W !,"Average Days After DOS: ",?28,$J(ACHSAVG,10,2),!

HDR ; Paginate.

 S ACHSPG=ACHSPG+1

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

 I ACHSRTYP="D" D

 .W !!,?50,"Days Prior",?64,"Days After"

 .W !,"PO Number",?16,"Date of Service",?33,"Date of Issue",?49,"or = to DOS",?67,"DOS"

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

ACHSRGPR  ;IHS/OIT/FCJ - GPRA REPORT DOS VS DATE PO ISS

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

 +2       ;

 +3       ;Auth end DOS used, if not available then Auth Beg DOS

ST        ;

 +1        SET ACHSIO=IO

 +2        WRITE !!,"This is a GPRA report to calculate the days between the Date of Service"

 +3        WRITE !,"and when the Purchase Order was issued. Date of Service is the estimated"

 +4        WRITE !,"End Date of Service, even if the document has been paid."

 +5        WRITE !!,"The Purchase Order will either be selected by Fiscal Year or the Date of"

 +6        WRITE !,"Service to fall within the Fiscal year Beginning and Ending date."

 +7        WRITE !!,"The report is selected and sorted by issue date."

 +8       ;

FY        ; Select FY.

 +1        SET ACHSACFY=$$FYSEL^ACHS(1)

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

               GOTO EXT

 +3        IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY))

               WRITE !!,*7,"Fiscal year '",ACHSACFY,"' does not exist. -- TRY AGAIN"

               GOTO FY

FYDT      ;BEG AND END DATES FOR THE FY, DOS >ACHSBFY OR <ACHSEFY

 +1        IF $PIECE(^ACHSF(DUZ(2),0),U,7)=1

               SET ACHSBFY=ACHSACFY-1701_($PIECE(^ACHSF(DUZ(2),0),U,6)-1)

               SET ACHSEFY=ACHSACFY-1700_($PIECE(^ACHSF(DUZ(2),0),U,6)-1)

 +2       IF '$TEST

               SET ACHSBFY=ACHSACFY-1700_($PIECE(^ACHSF(DUZ(2),0),U,6)-1)

               SET ACHSEFY=ACHSACFY-1699_($PIECE(^ACHSF(DUZ(2),0),U,6)-1)

 +3       ;

BDT       ; Enter beginning date.

 +1        SET ACHSBDT=$$DATE^ACHS("B","GPRA","")

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

               GOTO EXT

EDT       ; Enter the ending date.

 +1        SET ACHSEDT=$$DATE^ACHS("E","GPRA","")

 +2        IF $DATA(DUOUT)

               GOTO BDT

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

               GOTO EXT

           IF $$EBB^ACHS(ACHSBDT,ACHSEDT)

               GOTO EDT

DOS       ; REPORT BY DOS WITHIN FY OR FY

 +1       ; Enter FY or DOS

 +2        SET ACHSRTYD="F"

 +3        SET DIR(0)="S^F:Fiscal Year;D:Date of Service"

           SET DIR("B")="Fiscal Year"

           SET DIR("A")="Report PO's by "

 +4        SET DIR("?")="Report PO's by FY or by Date of service for sites that move money forward into one FY account."

 +5        DO ^DIR

 +6        IF $DATA(DUOUT)

               GOTO EXT

           IF $DATA(DTOUT)

               GOTO EXT

           IF $DATA(DIROUT)

               GOTO EXT

 +7        SET ACHSRTYD=Y

TYPE      ; TYPE OF REPORT SUMARRY OR DETAILED

 +1       ; Enter Summary or Detail

 +2        SET DIR(0)="S^S:SUMMARY;D:DETAILED"

           SET DIR("A")="Report Type "

           SET DIR("B")="SUMMARY"

 +3        SET DIR("?")="Detail will display indiviual PO, Summary will display only the totals"

 +4        DO ^DIR

 +5        IF $DATA(DUOUT)

               GOTO EXT

           IF $DATA(DTOUT)

               GOTO EXT

           IF $DATA(DIROUT)

               GOTO EXT

 +6        SET ACHSRTYP=Y

DEV       ; Select device for report.

 +1        WRITE !

 +2        SET %=$$PB^ACHS

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

               GOTO EXT

 +4        IF %="B"

               DO VIEWR^XBLM("CALC^ACHSRGPR")

               DO EN^XBVK("VALM")

               GOTO EXT

 +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 EXT

 +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^ACHSRGPR"

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

 +14       FOR %="ACHSQIO","ACHSBDT","ACHSEDT","ACHSRTYP","ACHSACFY","ACHSEFY","ACHSBFY","ACHSRTYD"

               SET ZTSAVE(%)=""

 +15       DO ^%ZTLOAD

 +16       IF '$DATA(ZTSK)

               GOTO DEV

 +17      ;

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

 +19      ;

 +20      ;

CALC      ;EP - TaskMan.

 +1        DO FC^ACHSUF

 +2        IF $DATA(ACHSERR)

               IF ACHSERR=1

                   GOTO EXT

 +3        SET ACHSTRDT=ACHSBDT-1

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

 +5        SET (^TMP("ACHSRGPR",$JOB,"TOTDOC"),^TMP("ACHSRGPR",$JOB,"TOTPDOC"),^TMP("ACHSRGPR",$JOB,"TOTADOC"))=0

 +6        SET (^TMP("ACHSRGPR",$JOB,"TOTDAY"),^TMP("ACHSRGPR",$JOB,"TOTPDAY"),^TMP("ACHSRGPR",$JOB,"TOTADAY"))=0

 +7       ;

TRDT      ; Loop thru transaction date x-ref.

 +1        FOR

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

               IF (ACHSTRDT>ACHSEDT)!(ACHSTRDT'?1N.N)

                   QUIT

               Begin DoDot:1

 +2       ; Loop thru transaction type

 +3                SET ACHSTYPE=""

 +4                FOR

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

                       IF ACHSTYPE=""

                           QUIT

                       Begin DoDot:2

 +5                        IF ACHSTYPE'="I"

                               QUIT

 +6                        SET DA=0

 +7                        FOR

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

                               IF DA'?1N.N

                                   QUIT

                               Begin DoDot:3

 +8       ;QUIT IF CANCELLED

                                   IF ('$DATA(^ACHSF(DUZ(2),"D",DA,0)))!($PIECE(^ACHSF(DUZ(2),"D",DA,0),U,12)=4)

                                       QUIT

 +9       ;IF REPORT BY FY TEST FOR FY

                                   IF ACHSRTYD="F"

                                       IF ACHSACFY'=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,27)

                                           QUIT

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

                                   SET (X1,ACHSORDT)=$PIECE(^(0),U,2)

 +11                               DO DOSDT

 +12      ;S (X2,ACHSEDOS)=$S($P(^ACHSF(DUZ(2),"D",DA,3),U,2)'="":$P(^ACHSF(DUZ(2),"D",DA,3),U,2),1:$P(^ACHSF(DUZ(2),"D",DA,3),U))

 +13      ;IF REPORT BY DOS TEST FOR DOS

                                   IF ACHSRTYD="D"

                                       IF (ACHSEDOS<ACHSBFY)!(ACHSEDOS>ACHSEFY)

                                           QUIT

 +14                               DO ^%DTC

 +15                               SET ACHSORDT=$EXTRACT(ACHSORDT,4,5)_"/"_$EXTRACT(ACHSORDT,6,7)_"/"_$EXTRACT(ACHSORDT,2,3)

 +16                               SET ACHSEDOS=$EXTRACT(ACHSEDOS,4,5)_"/"_$EXTRACT(ACHSEDOS,6,7)_"/"_$EXTRACT(ACHSEDOS,2,3)

 +17                               IF ACHSRTYP="D"

                                       Begin DoDot:4

 +18                                       SET ^TMP("ACHSRGPR",$JOB,ACHSDOCN)=$EXTRACT(ACHSACFY,3,4)_"-"_ACHSFC_"-"_ACHSDOCN_U_ACHSEDOS_U_ACHSORDT

 +19                                       IF X>0

                                               SET $PIECE(^TMP("ACHSRGPR",$JOB,ACHSDOCN),U,5)=X

 +20                                      IF '$TEST

                                               SET $PIECE(^TMP("ACHSRGPR",$JOB,ACHSDOCN),U,4)=$FNUMBER(X,"-")

                                       End DoDot:4

 +21                               IF X>0

                                       SET ^TMP("ACHSRGPR",$JOB,"TOTADAY")=^TMP("ACHSRGPR",$JOB,"TOTADAY")+X

                                       SET ^("TOTADOC")=^("TOTADOC")+1

 +22                              IF '$TEST

                                       SET ^TMP("ACHSRGPR",$JOB,"TOTPDAY")=^TMP("ACHSRGPR",$JOB,"TOTPDAY")+$FNUMBER(X,"-")

                                       SET ^("TOTPDOC")=^("TOTPDOC")+1

 +23                               SET ^TMP("ACHSRGPR",$JOB,"TOTDOC")=^TMP("ACHSRGPR",$JOB,"TOTDOC")+1

 +24                               SET ^TMP("ACHSRGPR",$JOB,"TOTDAY")=^TMP("ACHSRGPR",$JOB,"TOTDAY")+X

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +25       DO PRINT

 +26      ;

EXT       ; Kill vars, close device, quit.

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

               XECUTE ACHSPPC

 +2       IF '$TEST

               DO ^%ZISC

 +3        DO EN^XBVK("ACHS")

           IF '$DATA(ZTQUEUED)

               DO ^ACHSVAR

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

 +5        KILL DTOUT,DUOUT,ZTSK

 +6        QUIT

 +7       ;

DOSDT     ;FIND THE DOS TO USE

 +1       ;TEST FOR PAID DOCUMENT, USE ACT DOS OR EST EDOS IF NOT DEFINED USE EST BEG DOS

 +2        SET X2=""

 +3        IF $PIECE(^ACHSF(DUZ(2),"D",DA,0),U,12)=3

               Begin DoDot:1

 +4                SET T=0

FOR

                       SET T=$ORDER(^ACHSF(DUZ(2),"D",DA,"T",T))

                       IF T'?1N.N

                           QUIT

                       IF $PIECE(^ACHSF(DUZ(2),"D",DA,"T",T,0),U,2)="P"

                           SET (X2,ACHSEDOS)=$PIECE(^(0),U,10)

                           QUIT

               End DoDot:1

 +5       ;EDOS="" use EST Beg DOS

           IF X2=""

               SET (X2,ACHSEDOS)=$SELECT($PIECE(^ACHSF(DUZ(2),"D",DA,3),U,2)'="":$PIECE(^ACHSF(DUZ(2),"D",DA,3),U,2),1:$PIECE(^ACHSF(DUZ(2),"D",DA,3),U))

 +6        QUIT

 +7       ;

PRINT     ;

 +1        SET ACHSVNDR=""

           SET ACHST1=$$C^XBFUNC("GPRA REPORT-AVERAGE DAYS BETWEEN PO ISSUE AND DOS")

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

           SET X3=0

 +3        DO BRPT^ACHSFU

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

               XECUTE ACHSPPO

 +5        IF ACHSRTYP="D"

               DO HDR

               DO DET

 +6        SET ACHSRTYP="S"

           DO HDR

           DO SUM

 +7        GOTO EXT

           QUIT

 +8       ;

DET       ;DETAILED REPORT

 +1        SET ACHSDOCN=""

 +2        FOR

               SET ACHSDOCN=$ORDER(^TMP("ACHSRGPR",$JOB,ACHSDOCN))

               IF ACHSDOCN'?1N.N

                   QUIT

               Begin DoDot:1

 +3                WRITE !,$PIECE(^TMP("ACHSRGPR",$JOB,ACHSDOCN),U),?19,$PIECE(^(ACHSDOCN),U,2),?35,$PIECE(^(ACHSDOCN),U,3),?51,$JUSTIFY($PIECE(^(ACHSDOCN),U,4),5),?65,$JUSTIFY($PIECE(^(ACHSDOCN),U,5),5)

 +4                IF $Y>ACHSBM

                       DO RTRN^ACHS

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

                           QUIT

                       DO HDR

               End DoDot:1

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

                   QUIT

 +5        QUIT

SUM       ;SUMMARY REPORT

 +1       ;

 +2        WRITE !!,"TOTAL Documents:  ",$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTDOC"),10)

 +3        WRITE !,"TOTAL Days: ",?18,$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTDAY"),10)

 +4        SET ACHSAVG=0

 +5        IF ^TMP("ACHSRGPR",$JOB,"TOTDOC")

               SET ACHSAVG=$SELECT(^TMP("ACHSRGPR",$JOB,"TOTDOC")>0:^TMP("ACHSRGPR",$JOB,"TOTDAY")/^TMP("ACHSRGPR",$JOB,"TOTDOC"),1:0)

 +6        WRITE !,"Average Days: ",?18,$JUSTIFY(ACHSAVG,10,2),!

 +7        WRITE !!,"TOTAL Documents Prior or = to DOS:  ",?37,$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTPDOC"),10)

 +8        WRITE !,"TOTAL Days for Prior or = to DOS: ",?37,$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTPDAY"),10)

 +9        SET ACHSAVG=0

 +10       IF ^TMP("ACHSRGPR",$JOB,"TOTPDOC")>0

               SET ACHSAVG=$SELECT(^TMP("ACHSRGPR",$JOB,"TOTDOC")>0:^TMP("ACHSRGPR",$JOB,"TOTPDAY")/^TMP("ACHSRGPR",$JOB,"TOTPDOC"),1:0)

 +11       WRITE !,"Average Days Prior or = to DOS: ",?37,$JUSTIFY(ACHSAVG,10,2),!

 +12       WRITE !!,"TOTAL Documents After DOS:  ",?28,$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTADOC"),10)

 +13       WRITE !,"TOTAL Days After DOS: ",?28,$JUSTIFY(^TMP("ACHSRGPR",$JOB,"TOTADAY"),10)

 +14       SET ACHSAVG=0

 +15       IF ^TMP("ACHSRGPR",$JOB,"TOTADOC")

               IF 1>0

                   SET ACHSAVG=$SELECT(^TMP("ACHSRGPR",$JOB,"TOTDOC")>0:^TMP("ACHSRGPR",$JOB,"TOTADAY")/^TMP("ACHSRGPR",$JOB,"TOTADOC"),1:0)

 +16       WRITE !,"Average Days After DOS: ",?28,$JUSTIFY(ACHSAVG,10,2),!

 +17       QUIT

 +18      ;

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        IF ACHSRTYP="D"

               Begin DoDot:1

 +4                WRITE !!,?50,"Days Prior",?64,"Days After"

 +5                WRITE !,"PO Number",?16,"Date of Service",?33,"Date of Issue",?49,"or = to DOS",?67,"DOS"

               End DoDot:1

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

 +7        QUIT

ACHSRGPR.m