Routine: ACHSDSF

ACHSDSF ; IHS/ITSC/PMF - DOC STATUS REPORT BY FY (1/2) - FORMAT & DEVICE ;   [ 10/16/2001   8:16 AM ]

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

 S ACHSIO=IO

FYSEL ; Select fiscal year for report.

 S ACHSFY=$$FYSEL^ACHS

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

 S %=$$FY^ACHSVAR($E(ACHSFY,3,4)),ACHSBDT=$P(%,U),ACHSEDT=$P(%,U,2)

 I ACHSEDT>DT S ACHSEDT=DT

TYPE ; Select type of report.

 W !!,"Which type of report?",!!,"  1.  OPEN DOCUMENTS only",!,"  2.  CLOSED DOCUMENTS only",!,"  3.  COMBINED list",!!,"  ENTER OPTION (1-3) 3//"

 D READ^ACHSFU

 I Y="" S Y=3

 G K:$D(DTOUT),Q:Y?1"?".E,FYSEL:$D(DUOUT)

 I "123"[Y,Y>0,Y<4 S ACHSRPT=Y G DEV

 W !!,*7,"  Enter only a 1, 2, or 3"

 G TYPE

Q ;

 W !!,"Choice 1 - only open documents will be listed.",!,"Choice 2 - only documents which have been paid or cancelled will be listed.",!,"Choice 3 - open and closed documents will be listed together."

 G TYPE

DEV ;

 S %=$$PB^ACHS

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

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

 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^ACHSDSF",ZTDESC="CHS Document Status, Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT),ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL

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

 D ^%ZTLOAD

 G:'$D(ZTSK) DEV

K ;

 D EN^XBVK("ACHS"),^ACHSVAR

 K ZTIO,ZTSK

 D ^%ZISC

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($S(ACHSRPT=1:"OPEN DOCUMENTS",ACHSRPT=2:"CLOSED DOCUMENTS",1:"OPEN AND CLOSED DOCUMENTS"),80),ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)

 D BRPT^ACHSFU,HDR

 S X3=0,ACHSDNU=1_($E(ACHSFY,4))_"00000"

A ; Main loop. Check end date.

 S ACHSDNU=$O(^ACHSF(DUZ(2),"D","B",ACHSDNU))

 G END:ACHSDNU="",END:$E(ACHSDNU,2)'=$E(ACHSFY,4)

 S ACHSDIEN=""

B ; Get IEN.

 S ACHSDIEN=$O(^ACHSF(DUZ(2),"D","B",ACHSDNU,ACHSDIEN))

 G A:ACHSDIEN=""

C ;

 G A:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSSTS=$S($P(^(0),U,12)=3:"P",$P(^(0),U,12)=4:"C",1:"OPEN")

 I ACHSRPT=1,"PC"[ACHSSTS G B

 I ACHSRPT=2,"PC"'[ACHSSTS G B

 S ACHSDOC1=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U),ACHSVPTR=$P(^(0),U,8),ACHSDOC2=$P(^(0),U,14),ACHS("$")=$P(^(0),U,9),ACHSTOS=$P(^(0),U,4),ACHSBLNK=+$P(^(0),U,3),ACHSDDT=$P(^(0),U,2),ACHS("$PCAN")=0

 G B:ACHSVPTR']"",B:'$D(^AUTTVNDR(ACHSVPTR,0)) S ACHSVNDR=$P(^(0),U) S ACHSEIN="" S:$D(^(11)) ACHSEIN=$P(^(11),U)_" "_$P(^(11),U,2)

 S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1

 K ACHSNAME

 S DFN=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,22)

 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")

 G B:'$D(ACHSNAME)

 S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) ACHS("$")=+^("PA")

 S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) ACHS("$")=+^("ZA")

 ; I ACHSSTS="C" S ACHS("$")=0

 F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS)) Q:+ACHS=0  D

 . S ACHSDOS=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,10)

 . I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,2)="C",$P(^(0),U,5)="F" S ACHS("$")=$P(^(0),U,4)

 . I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,2)="C",$P(^(0),U,5)="P" S ACHS("$PCAN")=ACHS("$PCAN")+$P(^(0),U,4)

.Q

 W $E(ACHSNAME,1,24),?25,$E(ACHSVNDR,1,26),?52,$E(ACHSDDT,4,7),$E(ACHSDDT,2,3)

 W:ACHSDOS]"" "/",$E(ACHSDOS,4,7)

 W ?64

 G P1:"PC"'[ACHSSTS

 W $S(ACHSSTS="P":"PAID",1:"CANCEL")

 S X=ACHS("$")

 D COMMA^%DTC

 W ?80-$L(X),X

 G P2

P1 ; Open doc amt.

 I +ACHS("$")'=0 S X=ACHS("$") D COMMA^%DTC W ?80-$L(X),X

P2 ;

 W !,ACHSDOC,?25,ACHSEIN,?52,$S(ACHSTOS=1:"HOSPITAL",ACHSTOS=2:"DENTAL",ACHSTOS=3:"OUTPATIENT",1:"")

 I ACHS("$PCAN") W ?64,"P-CAN" S X=$FN(ACHS("$PCAN"),",",2) W ?79-$L(X),X

 I ACHSSTS="P" S ACHSTOTP=ACHSTOTP+1,ACHSTOTP("$")=ACHSTOTP("$")+ACHS("$") G P3

 I ACHSSTS="C" S ACHSCNX=ACHSCNX+1,ACHSCNX("$")=ACHSCNX("$")+ACHS("$") G P3

 S ACHSOPEN=ACHSOPEN+1,ACHSOPEN("$")=ACHSOPEN("$")+ACHS("$")

 I ACHS("$PCAN") S ACHSCNX("$")=ACHSCNX("$")+ACHS("$PCAN")

P3 ; End of transaction.

 W !!

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

G B

END ; Print totals.

 W !,$$REPEAT^XLFSTR("-",80),!

 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,!

 I ACHSCNX S X=ACHSCNX("$") D COMMA^%DTC W "TOTAL CANCELLED DOCUMENTS:",$J(ACHSCNX,6),?40,"TOTAL DOLLARS CANCELLED:  ",X,!

 I ACHSOPEN S X=ACHSOPEN("$") D COMMA^%DTC W "TOTAL OPEN DOCUMENTS:",$J(ACHSOPEN,11),?40,"TOTAL DOLLARS OPEN:       ",X

 I ACHSCNX W !,"NOTE: Partial Cancels are not included in count, but ARE included in $."

 D RTRN^ACHS

 W @IOF

KILL ; Do ERPT, kill vars, quit.

 D ERPT^ACHS

 K ACHSDDT,ACHSDNU,ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSEIN,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,ACHSDIEN,DFN,X2,X3,ACHSFY

HDR ; Doc status rpt header.

 S ACHSPG=ACHSPG+1

 W @IOF,!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("***  CONTRACT HEALTH MANAGEMENT SYSTEM  ***",80),!,ACHSLOC,!,$$C^XBFUNC("DOCUMENT STATUS REPORT, FY "_ACHSFY,80)

 I $D(ZTQUEUED),$G(ZTSK) W ?77-$L(ZTSK),"(",ZTSK,")"

 W !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Patient Name",?25,"Provider of Service",?52,"Issue /DOS",!,"Document number",?25,"EIN Number",?52,"Type",?64,"Status",?73,"Amount",!,$$REPEAT^XLFSTR("=",80),!

ACHSDSF   ; IHS/ITSC/PMF - DOC STATUS REPORT BY FY (1/2) - FORMAT & DEVICE ;   [ 10/16/2001   8:16 AM ]

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

 +2       ;

 +3        SET ACHSIO=IO

FYSEL     ; Select fiscal year for report.

 +1        SET ACHSFY=$$FYSEL^ACHS

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

               GOTO K

 +3        SET %=$$FY^ACHSVAR($EXTRACT(ACHSFY,3,4))

           SET ACHSBDT=$PIECE(%,U)

           SET ACHSEDT=$PIECE(%,U,2)

 +4        IF ACHSEDT>DT

               SET ACHSEDT=DT

TYPE      ; Select type of report.

 +1        WRITE !!,"Which type of report?",!!,"  1.  OPEN DOCUMENTS only",!,"  2.  CLOSED DOCUMENTS only",!,"  3.  COMBINED list",!!,"  ENTER OPTION (1-3) 3//"

 +2        DO READ^ACHSFU

 +3        IF Y=""

               SET Y=3

 +4        IF $DATA(DTOUT)

               GOTO K

           IF Y?1"?".E

               GOTO Q

           IF $DATA(DUOUT)

               GOTO FYSEL

 +5        IF "123"[Y

               IF Y>0

                   IF Y<4

                       SET ACHSRPT=Y

                       GOTO DEV

 +6        WRITE !!,*7,"  Enter only a 1, 2, or 3"

 +7        GOTO TYPE

 +8       ;

Q         ;

 +1        WRITE !!,"Choice 1 - only open documents will be listed.",!,"Choice 2 - only documents which have been paid or cancelled will be listed.",!,"Choice 3 - open and closed documents will be listed together."

 +2        GOTO TYPE

 +3       ;

DEV       ;

 +1        SET %=$$PB^ACHS

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

               DO K

               QUIT

 +3        IF %="B"

               DO VIEWR^XBLM("PRINT^ACHSDSF")

               DO EN^XBVK("VALM")

               DO K

               QUIT

 +4        SET %ZIS="OPQ"

 +5        DO ^%ZIS

 +6        IF POP

               DO HOME^%ZIS

               GOTO K

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

               GOTO PRINT

 +8        KILL IO("Q")

 +9        IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")

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

               DO ^%ZISC

               GOTO DEV

 +10       SET ZTRTN="PRINT^ACHSDSF"

           SET ZTDESC="CHS Document Status, Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)

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

 +11       FOR %="ACHSBDT","ACHSEDT","ACHSFY","ACHSRPT"

               SET ZTSAVE(%)=""

 +12       DO ^%ZTLOAD

 +13       IF '$DATA(ZTSK)

               GOTO DEV

K         ;

 +1        DO EN^XBVK("ACHS")

           DO ^ACHSVAR

 +2        KILL ZTIO,ZTSK

 +3        DO ^%ZISC

 +4        QUIT

 +5       ;

PRINT     ;EP - From TaskMan.

 +1        DO FC^ACHSUF

 +2        IF $DATA(ACHSERR)

               IF ACHSERR=1

                   KILL ZTSK

                   GOTO KILL

 +3        SET (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0

 +4        SET ACHST1=$$C^XBFUNC($SELECT(ACHSRPT=1:"OPEN DOCUMENTS",ACHSRPT=2:"CLOSED DOCUMENTS",1:"OPEN AND CLOSED DOCUMENTS"),80)

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

 +5        DO BRPT^ACHSFU

           DO HDR

 +6        SET X3=0

           SET ACHSDNU=1_($EXTRACT(ACHSFY,4))_"00000"

A         ; Main loop. Check end date.

 +1        SET ACHSDNU=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSDNU))

 +2        IF ACHSDNU=""

               GOTO END

           IF $EXTRACT(ACHSDNU,2)'=$EXTRACT(ACHSFY,4)

               GOTO END

 +3        SET ACHSDIEN=""

B         ; Get IEN.

 +1        SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSDNU,ACHSDIEN))

 +2        IF ACHSDIEN=""

               GOTO A

C         ;

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

               GOTO A

           SET ACHSSTS=$SELECT($PIECE(^(0),U,12)=3:"P",$PIECE(^(0),U,12)=4:"C",1:"OPEN")

 +2        IF ACHSRPT=1

               IF "PC"[ACHSSTS

                   GOTO B

 +3        IF ACHSRPT=2

               IF "PC"'[ACHSSTS

                   GOTO B

 +4        SET ACHSDOC1=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U)

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

           SET ACHSDOC2=$PIECE(^(0),U,14)

           SET ACHS("$")=$PIECE(^(0),U,9)

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

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

           SET ACHSDDT=$PIECE(^(0),U,2)

           SET ACHS("$PCAN")=0

 +5        IF ACHSVPTR']""

               GOTO B

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

               GOTO B

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

           SET ACHSEIN=""

           IF $DATA(^(11))

               SET ACHSEIN=$PIECE(^(11),U)_" "_$PIECE(^(11),U,2)

 +6        SET ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1

 +7        KILL ACHSNAME

 +8        SET DFN=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,22)

 +9        IF +DFN>0

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

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

 +10       IF '$DATA(ACHSNAME)

               IF ACHSBLNK

                   SET ACHSNAME=$SELECT(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")

 +11       IF '$DATA(ACHSNAME)

               GOTO B

 +12       IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))

               SET ACHS("$")=+^("PA")

 +13       IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))

               SET ACHS("$")=+^("ZA")

 +14      ; I ACHSSTS="C" S ACHS("$")=0

 +15       FOR ACHS=0:0

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

               IF +ACHS=0

                   QUIT

               Begin DoDot:1

 +16               SET ACHSDOS=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,10)

 +17               IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,2)="C"

                       IF $PIECE(^(0),U,5)="F"

                           SET ACHS("$")=$PIECE(^(0),U,4)

 +18               IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHS,0),U,2)="C"

                       IF $PIECE(^(0),U,5)="P"

                           SET ACHS("$PCAN")=ACHS("$PCAN")+$PIECE(^(0),U,4)

 +19               QUIT

               End DoDot:1

 +20       WRITE $EXTRACT(ACHSNAME,1,24),?25,$EXTRACT(ACHSVNDR,1,26),?52,$EXTRACT(ACHSDDT,4,7),$EXTRACT(ACHSDDT,2,3)

 +21       IF ACHSDOS]""

               WRITE "/",$EXTRACT(ACHSDOS,4,7)

 +22       WRITE ?64

 +23       IF "PC"'[ACHSSTS

               GOTO P1

 +24       WRITE $SELECT(ACHSSTS="P":"PAID",1:"CANCEL")

 +25       SET X=ACHS("$")

 +26       DO COMMA^%DTC

 +27       WRITE ?80-$LENGTH(X),X

 +28       GOTO P2

 +29      ;

P1        ; Open doc amt.

 +1        IF +ACHS("$")'=0

               SET X=ACHS("$")

               DO COMMA^%DTC

               WRITE ?80-$LENGTH(X),X

P2        ;

 +1        WRITE !,ACHSDOC,?25,ACHSEIN,?52,$SELECT(ACHSTOS=1:"HOSPITAL",ACHSTOS=2:"DENTAL",ACHSTOS=3:"OUTPATIENT",1:"")

 +2        IF ACHS("$PCAN")

               WRITE ?64,"P-CAN"

               SET X=$FNUMBER(ACHS("$PCAN"),",",2)

               WRITE ?79-$LENGTH(X),X

 +3        IF ACHSSTS="P"

               SET ACHSTOTP=ACHSTOTP+1

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

               GOTO P3

 +4        IF ACHSSTS="C"

               SET ACHSCNX=ACHSCNX+1

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

               GOTO P3

 +5        SET ACHSOPEN=ACHSOPEN+1

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

 +6        IF ACHS("$PCAN")

               SET ACHSCNX("$")=ACHSCNX("$")+ACHS("$PCAN")

P3        ; End of transaction.

 +1        WRITE !!

 +2        IF $Y>ACHSBM

               DO RTRN^ACHS

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

                   GOTO KILL

               DO HDR

 +3        GOTO B

 +4       ;

END       ; Print totals.

 +1        WRITE !,$$REPEAT^XLFSTR("-",80),!

 +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        IF ACHSCNX

               SET X=ACHSCNX("$")

               DO COMMA^%DTC

               WRITE "TOTAL CANCELLED DOCUMENTS:",$JUSTIFY(ACHSCNX,6),?40,"TOTAL DOLLARS CANCELLED:  ",X,!

 +5        IF ACHSOPEN

               SET X=ACHSOPEN("$")

               DO COMMA^%DTC

               WRITE "TOTAL OPEN DOCUMENTS:",$JUSTIFY(ACHSOPEN,11),?40,"TOTAL DOLLARS OPEN:       ",X

 +6        IF ACHSCNX

               WRITE !,"NOTE: Partial Cancels are not included in count, but ARE included in $."

 +7        DO RTRN^ACHS

 +8        WRITE @IOF

KILL      ; Do ERPT, kill vars, quit.

 +1        DO ERPT^ACHS

 +2        KILL ACHSDDT,ACHSDNU,ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSEIN,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,ACHSDIEN,DFN,X2,X3,ACHSFY

 +3        QUIT

 +4       ;

HDR       ; Doc status rpt header.

 +1        SET ACHSPG=ACHSPG+1

 +2        WRITE @IOF,!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("***  CONTRACT HEALTH MANAGEMENT SYSTEM  ***",80),!,ACHSLOC,!,$$C^XBFUNC("DOCUMENT STATUS REPORT, FY "_ACHSFY,80)

 +3        IF $DATA(ZTQUEUED)

               IF $GET(ZTSK)

                   WRITE ?77-$LENGTH(ZTSK),"(",ZTSK,")"

 +4        WRITE !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Patient Name",?25,"Provider of Service",?52,"Issue /DOS",!,"Document number",?25,"EIN Number",?52,"Type",?64,"Status",?73,"Amount",!,$$REPEAT^XLFSTR("=",80),!

 +5        QUIT

 +6       ;

ACHSDSF.m