ACHSDHQ.m

ACHSDHQ ; IHS/ITSC/PMF - DENIAL REPORT HQ1 ; [ 10/31/2003  11:40 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,5,6,18**;JUNE 11,2001

 ;ACHS*3.1*3  allow denials to be reversed

 ;ACHS*3.1*5 12/06/2002  report is wrong if there are reasons with the same text

 ;ACHS*3.1*6 3/20/2003 request to list cancels and reversal in total count

 ;

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

 I ACHSBDT<1 D END Q

 ;

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

 ;

 ; --- Select print device

 ;S OK=0 D  I 'OK D END Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 S ACHSOK=0 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 D  I 'ACHSOK D END Q  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 . S %ZIS="PQ"

 . D ^%ZIS

 . I POP D HOME^%ZIS Q

 . ;I '$D(IO("Q")) S OK=1 Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 . I '$D(IO("Q")) S ACHSOK=1 Q  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 . S ZTRTN="START^ACHSDHQ",ZTIO="",ZTDESC="Print CHS DENIAL HQ1 Report",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL

 . F %="ACHSBDT","ACHSEDT","ACHSQIO" S ZTSAVE(%)=""

 . D ^%ZTLOAD

 . I '$D(ZTSK) Q

 . ;S OK=1 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 . S ACHSOK=1 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 . Q

 I $D(IO("Q")),$D(ZTSK) D END Q  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 ;

 ;

START ;EP - From TaskMan.

 N ACHSISDT,ACHSA,ACHSNR,ACHSTCN

 ;S ACHSISDT=ACHSBDT-1,ACHSTCN=0

 ;IHS/SET/JVK ADDED BELOW  3/20/2003 ACHS*3.1*6

 S ACHSISDT=ACHSBDT-1,ACHSTCN=0,ACHSYCN=0,ACHSRCN=0

 ;

 F  S ACHSISDT=$O(^ACHSDEN(DUZ(2),"D","AISSUE",ACHSISDT)) Q:ACHSISDT=""  Q:ACHSISDT>ACHSEDT  Q:ACHSISDT<ACHSBDT  D

 . S ACHSA=0 F  S ACHSA=$O(^ACHSDEN(DUZ(2),"D","AISSUE",ACHSISDT,ACHSA)) Q:ACHSA=""  D

 ..; I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="Y" Q

 ..; IHS/SET/JVK 3/20/2003 ADDED BELOW ACHS*3.1*6

 .. I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="Y" S ACHSYCN=ACHSYCN+1 Q

 .. ;

 .. ;010202  pmf  add next line

 .. ;Y means cancelled.  R means reversed

 .. ; IHS/SET/JVK 3/20/2003 COMMENT OUT BELOW ACHS*3.1*6

 .. ;I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="R" Q  ; ACHS*3.1*3

 .. ;

 .. ; IHS/SET/JVK 3/20/2003 ADDED BELOW ACHS*3.1*6

 .. I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="R" S ACHSRCN=ACHSRCN+1 Q  ; ACHS*3.1*6

 .. ;I $E($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)))="#";IHS/SET/GTH ACHS*3.1*5 12/06/2002

 .. I $E($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)))="#" Q  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 .. ;

 .. S ACHSNR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U)

 .. I 'ACHSNR S ACHSNR=0

 .. S ACHS(ACHSNR)=$G(ACHS(ACHSNR))+1,ACHSTCN=ACHSTCN+1

 .. Q

 . Q

 ;

 D BRPT^ACHS,HDR

 ;

 ;ACHS*3.1*5 12/06/2002 pmf  the report was using the reason as a

 ;   subscript.  however, if more than one reason had the same

 ;   text on it, one would overwrite the other.

 ;   now we use the reason AND it's subscript when we place it

 ;   into the array for display.

 ;S ACHSNR=0 F  S ACHSNR=$O(ACHS(ACHSNR)) Q:+ACHSNR=0  S ACHSX($P($G(^ACHSDENS(ACHSNR,0)),U))=ACHS(ACHSNR);ACHS*3.1*5 12/06/2002

 S ACHSNR=0 F  S ACHSNR=$O(ACHS(ACHSNR)) Q:+ACHSNR=0  S ACHSREA=$P($G(^ACHSDENS(ACHSNR,0)),U),ACHSX(ACHSREA_U_ACHSNR)=ACHS(ACHSNR) ;ACHS*3.1*5 12/06/2002

 ;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 I $D(ACHS(0)) S ACHSX("<Missing>^0")=ACHS(0)

 ;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 ;

 ;S ACHSNR=0 F  S ACHSNR=$O(ACHSX(ACHSNR)) Q:ACHSNR=""  W ?5,ACHSNR,?65,$J($FN(ACHSX(ACHSNR),","),8),!! I $Y>ACHSBM D RTRN^ACHS Q:$G(ACHSQUIT)  D HDR;ACHS*3.1*5 12/06/2002

 S ACHSNR="" F  S ACHSNR=$O(ACHSX(ACHSNR)) Q:ACHSNR=""  W ?5,$P(ACHSNR,U),?65,$J($FN(ACHSX(ACHSNR),","),8),!! I $Y>ACHSBM D RTRN^ACHS Q:$G(ACHSQUIT)  D HDR ;ACHS*3.1*5 12/06/2002

 ;

 ;

 I $D(ACHSD(0)) W ?5,"<Primary Denial Reason MISSING>",?65,$J($FN(ACHS(0),","),8),!! I $Y>ACHSBM D RTRN^ACHS Q:$G(ACHSQUIT)  D HDR

 W !!,$$REPEAT^XLFSTR("-",79),!!?25,"TOTAL DOCUMENTS",?65,$J($FN(ACHSTCN,","),8)

 ;Begin New Code;IHS/SET/JVK ACHS*3.1*6 3/20/2003

 W !,?25,"TOTAL CANCELED: ",?65,$J($FN(ACHSYCN,","),8)

 W !,?25,"TOTAL REVERSED: ",?65,$J($FN(ACHSRCN,","),8)

 W !,?25,"GRAND TOTAL: ",?65,$J($FN((ACHSTCN+ACHSYCN+ACHSRCN),","),8)

 ;End New Code;IHS/SET/JVK ACHS*3.1*6 3/20/2003

 D ERPT^ACHS

 K ACHSYCN,ACHSRCN

 Q

 ;

HDR ; --- Paginate, write header

 W @IOF,!!,ACHSLOC,!,$$C^ACHS("CONTRACT HEALTH SERVICE DENIALS (HQ TABLE 1)",80),!,$$C^ACHS("From "_$$FMTE^XLFDT(ACHSBDT)_" To "_$$FMTE^XLFDT(ACHSEDT),80),!!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79),!!!

 Q

 ;

END ;

 D ^%ZISC

 K ACHSBDT,ACHSEDT,ACHSQIO

 Q

ACHSDHQ   ; IHS/ITSC/PMF - DENIAL REPORT HQ1 ; [ 10/31/2003  11:40 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,5,6,18**;JUNE 11,2001

 +2       ;ACHS*3.1*3  allow denials to be reversed

 +3       ;ACHS*3.1*5 12/06/2002  report is wrong if there are reasons with the same text

 +4       ;ACHS*3.1*6 3/20/2003 request to list cancels and reversal in total count

 +5       ;

 +6        SET ACHSBDT=$$DATE^ACHS("B","HQ1")

 +7        IF ACHSBDT<1

               DO END

               QUIT 

 +8       ;

 +9        SET ACHSEDT=$$DATE^ACHS("E","HQ1")

 +10      ;

 +11      ; --- Select print device

 +12      ;S OK=0 D  I 'OK D END Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +13      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           SET ACHSOK=0

 +14      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           Begin DoDot:1

 +15           SET %ZIS="PQ"

 +16           DO ^%ZIS

 +17           IF POP

                   DO HOME^%ZIS

                   QUIT 

 +18      ;I '$D(IO("Q")) S OK=1 Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +19      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

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

                   SET ACHSOK=1

                   QUIT 

 +20           SET ZTRTN="START^ACHSDHQ"

               SET ZTIO=""

               SET ZTDESC="Print CHS DENIAL HQ1 Report"

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

 +21           FOR %="ACHSBDT","ACHSEDT","ACHSQIO"

                   SET ZTSAVE(%)=""

 +22           DO ^%ZTLOAD

 +23           IF '$DATA(ZTSK)

                   QUIT 

 +24      ;S OK=1 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +25      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

               SET ACHSOK=1

 +26           QUIT 

           End DoDot:1

           IF 'ACHSOK

               DO END

               QUIT 

 +27      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           IF $DATA(IO("Q"))

               IF $DATA(ZTSK)

                   DO END

                   QUIT 

 +28      ;

 +29      ;

START     ;EP - From TaskMan.

 +1        NEW ACHSISDT,ACHSA,ACHSNR,ACHSTCN

 +2       ;S ACHSISDT=ACHSBDT-1,ACHSTCN=0

 +3       ;IHS/SET/JVK ADDED BELOW  3/20/2003 ACHS*3.1*6

 +4        SET ACHSISDT=ACHSBDT-1

           SET ACHSTCN=0

           SET ACHSYCN=0

           SET ACHSRCN=0

 +5       ;

 +6        FOR 

               SET ACHSISDT=$ORDER(^ACHSDEN(DUZ(2),"D","AISSUE",ACHSISDT))

               IF ACHSISDT=""

                   QUIT 

               IF ACHSISDT>ACHSEDT

                   QUIT 

               IF ACHSISDT<ACHSBDT

                   QUIT 

               Begin DoDot:1

 +7                SET ACHSA=0

                   FOR 

                       SET ACHSA=$ORDER(^ACHSDEN(DUZ(2),"D","AISSUE",ACHSISDT,ACHSA))

                       IF ACHSA=""

                           QUIT 

                       Begin DoDot:2

 +8       ; I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="Y" Q

 +9       ; IHS/SET/JVK 3/20/2003 ADDED BELOW ACHS*3.1*6

 +10                       IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="Y"

                               SET ACHSYCN=ACHSYCN+1

                               QUIT 

 +11      ;

 +12      ;010202  pmf  add next line

 +13      ;Y means cancelled.  R means reversed

 +14      ; IHS/SET/JVK 3/20/2003 COMMENT OUT BELOW ACHS*3.1*6

 +15      ;I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="R" Q  ; ACHS*3.1*3

 +16      ;

 +17      ; IHS/SET/JVK 3/20/2003 ADDED BELOW ACHS*3.1*6

 +18      ; ACHS*3.1*6

                           IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,0)),U,8)="R"

                               SET ACHSRCN=ACHSRCN+1

                               QUIT 

 +19      ;I $E($G(^ACHSDEN(DUZ(2),"D",ACHSA,0)))="#";IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +20      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

                           IF $EXTRACT($GET(^ACHSDEN(DUZ(2),"D",ACHSA,0)))="#"

                               QUIT 

 +21      ;

 +22                       SET ACHSNR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U)

 +23                       IF 'ACHSNR

                               SET ACHSNR=0

 +24                       SET ACHS(ACHSNR)=$GET(ACHS(ACHSNR))+1

                           SET ACHSTCN=ACHSTCN+1

 +25                       QUIT 

                       End DoDot:2

 +26               QUIT 

               End DoDot:1

 +27      ;

 +28       DO BRPT^ACHS

           DO HDR

 +29      ;

 +30      ;ACHS*3.1*5 12/06/2002 pmf  the report was using the reason as a

 +31      ;   subscript.  however, if more than one reason had the same

 +32      ;   text on it, one would overwrite the other.

 +33      ;   now we use the reason AND it's subscript when we place it

 +34      ;   into the array for display.

 +35      ;S ACHSNR=0 F  S ACHSNR=$O(ACHS(ACHSNR)) Q:+ACHSNR=0  S ACHSX($P($G(^ACHSDENS(ACHSNR,0)),U))=ACHS(ACHSNR);ACHS*3.1*5 12/06/2002

 +36      ;ACHS*3.1*5 12/06/2002

           SET ACHSNR=0

           FOR 

               SET ACHSNR=$ORDER(ACHS(ACHSNR))

               IF +ACHSNR=0

                   QUIT 

               SET ACHSREA=$PIECE($GET(^ACHSDENS(ACHSNR,0)),U)

               SET ACHSX(ACHSREA_U_ACHSNR)=ACHS(ACHSNR)

 +37      ;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +38       IF $DATA(ACHS(0))

               SET ACHSX("<Missing>^0")=ACHS(0)

 +39      ;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +40      ;

 +41      ;S ACHSNR=0 F  S ACHSNR=$O(ACHSX(ACHSNR)) Q:ACHSNR=""  W ?5,ACHSNR,?65,$J($FN(ACHSX(ACHSNR),","),8),!! I $Y>ACHSBM D RTRN^ACHS Q:$G(ACHSQUIT)  D HDR;ACHS*3.1*5 12/06/2002

 +42      ;ACHS*3.1*5 12/06/2002

           SET ACHSNR=""

           FOR 

               SET ACHSNR=$ORDER(ACHSX(ACHSNR))

               IF ACHSNR=""

                   QUIT 

               WRITE ?5,$PIECE(ACHSNR,U),?65,$JUSTIFY($FNUMBER(ACHSX(ACHSNR),","),8),!!

               IF $Y>ACHSBM

                   DO RTRN^ACHS

                   IF $GET(ACHSQUIT)

                       QUIT 

                   DO HDR

 +43      ;

 +44      ;

 +45       IF $DATA(ACHSD(0))

               WRITE ?5,"<Primary Denial Reason MISSING>",?65,$JUSTIFY($FNUMBER(ACHS(0),","),8),!!

               IF $Y>ACHSBM

                   DO RTRN^ACHS

                   IF $GET(ACHSQUIT)

                       QUIT 

                   DO HDR

 +46       WRITE !!,$$REPEAT^XLFSTR("-",79),!!?25,"TOTAL DOCUMENTS",?65,$JUSTIFY($FNUMBER(ACHSTCN,","),8)

 +47      ;Begin New Code;IHS/SET/JVK ACHS*3.1*6 3/20/2003

 +48       WRITE !,?25,"TOTAL CANCELED: ",?65,$JUSTIFY($FNUMBER(ACHSYCN,","),8)

 +49       WRITE !,?25,"TOTAL REVERSED: ",?65,$JUSTIFY($FNUMBER(ACHSRCN,","),8)

 +50       WRITE !,?25,"GRAND TOTAL: ",?65,$JUSTIFY($FNUMBER((ACHSTCN+ACHSYCN+ACHSRCN),","),8)

 +51      ;End New Code;IHS/SET/JVK ACHS*3.1*6 3/20/2003

 +52       DO ERPT^ACHS

 +53       KILL ACHSYCN,ACHSRCN

 +54       QUIT 

 +55      ;

HDR       ; --- Paginate, write header

 +1        WRITE @IOF,!!,ACHSLOC,!,$$C^ACHS("CONTRACT HEALTH SERVICE DENIALS (HQ TABLE 1)",80),!,$$C^ACHS("From "_$$FMTE^XLFDT(ACHSBDT)_" To "_$$FMTE^XLFDT(ACHSEDT),80),!!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79),!!!

 +2        QUIT 

 +3       ;

END       ;

 +1        DO ^%ZISC

 +2        KILL ACHSBDT,ACHSEDT,ACHSQIO

 +3        QUIT