Routine: ACHSDNU2

ACHSDNU2 ; IHS/ITSC/PMF - DENIAL UNMET NEED LIST (3/3) ; [ 10/16/2001   8:16 AM ]

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

 S $P(^TMP("ACHSDNU",$J,0),U,1,2)="^ACHSDNU2"

 K ^TMP("ACHSDNU",$J,0,"ACHSQIO")

 G K:'$D(^DD(9002071.01,400,0))!'$D(^DD(9002071.01,420,0))

 S ACHS=$P(^DD(9002071.01,400,0),U,3) F ACHS(1)=1:1 Q:$P(ACHS,";",ACHS(1))=""  S ACHS(2)=$P(ACHS,";",ACHS(1)),ACHS("UN",$P(ACHS(2),":"))=$P(ACHS(2),":",2)

 ;S ACHS=$P(^DD(9002071,420,0),U,3) F ACHS(1)=1:1 Q:$P(ACHS,";",ACHS(1))=""  S ACHS(2)=$P(ACHS,";",ACHS(1)),ACHS("CATG",$P(ACHS(2),":"))=$P(ACHS(2),":",2)

 ;GET MEDICAL CATEGORIES FROM CHS MEDICAL PRIORITIES

 S MEDPRI=0 F  S MEDPRI=$O(^ACHSMPRI(MEDPRI)) Q:+MEDPRI=0  D

 .S MEDPRI0=$G(^ACHSMPRI(MEDPRI,0))

 .S ACHS("CATG",MEDPRI)=$P(MEDPRI0,U,2)

 S ACHSCAT="",(ACHSTOT,ACHSDOL)=0

 S Y=ACHSBDT X ^DD("DD") S ACHS("BDT")=Y,Y=ACHSEDT X ^DD("DD") S ACHS("EDT")=Y,ACHST1=$$C^XBFUNC("For the period "_ACHS("BDT")_" through "_ACHS("EDT"),80)

 D BRPT^ACHSFU

A ;

 S ACHSCAT=$O(^TMP("ACHSUN",$J,ACHSCAT)) D CTOTAL:ACHSCAT=""&$D(ACHSTYPE) G END1:ACHSCAT="" D CTOTAL:$D(ACHSTOT1) S ACHSTYPE=ACHS("CATG",ACHSCAT),(ACHSTOT1,ACHSTOT1("$"))=0 D HDR S ACHSNEED=""

B S ACHSNEED=$O(^TMP("ACHSUN",$J,ACHSCAT,ACHSNEED)) G A:ACHSNEED="" I $Y>ACHSBM D RTRN^ACHS G K:$D(DUOUT)!$D(DTOUT) D HDR

 S ACHSISDT=0 W !,ACHS("UN",ACHSNEED),! F ACHS=1:1:$L(ACHS("UN",ACHSNEED)) W "-"

W !

C ;

 S ACHSISDT=$O(^TMP("ACHSUN",$J,ACHSCAT,ACHSNEED,ACHSISDT)) G B:+ACHSISDT=0 S ACHSNAME=""

D ;

 S ACHSNAME=$O(^TMP("ACHSUN",$J,ACHSCAT,ACHSNEED,ACHSISDT,ACHSNAME)) G C:ACHSNAME="" S DA=0

E ;

 S DA=$O(^TMP("ACHSUN",$J,ACHSCAT,ACHSNEED,ACHSISDT,ACHSNAME,DA)) G D:+DA=0 S ACHS("T$")=+^(DA),ACHSDNUM=$P(^ACHSDEN(DUZ(2),"D",DA,0),U)

 S Y=ACHSISDT X ^DD("DD") W "  ",Y,?16,ACHSDNUM,?29,ACHSNAME,?70,$J(ACHS("T$"),6,2),! I $Y>ACHSBM D RTRN^ACHS G K:$D(DUOUT)!$D(DTOUT) D HDR

 S ACHSTOT=ACHSTOT+1,ACHSTOT1=ACHSTOT1+1,ACHSTOT1("$")=ACHSTOT1("$")+ACHS("T$"),ACHSDOL=ACHSDOL+ACHS("T$")

G E

CTOTAL ;

 S X=ACHSTOT1("$"),X2="2$" D COMMA^%DTC W !,ACHS("="),!!,"TOTALS FOR ",ACHSTYPE,":  ",ACHSTOT1," DENIAL",$S(ACHSTOT1>1:"S",1:""),?65,X

END1 ; Print totals.

 I ACHSPG=0 W "Facility UN-MET NEED list for ",ACHSLOC,!!!,"(No un-met needs were recorded during this time period.)" G END2

 S X=ACHSDOL,X2="2$" D COMMA^%DTC W !,ACHS("="),!!!,"TOTAL DENIALS ON THIS REPORT: ",ACHSTOT," DENIAL",$S(ACHSTOT>1:"S",1:""),?65,X

END2 ; Ask RTRN, write IOF, kill vars, do ERPT, quit.

 D RTRN^ACHS W @IOF

K K ACHSCAT,ACHSDNUM,ACHSDOL,ACHSISDT,ACHSNAME,ACHSNEED,ACHSTOT,ACHSTOT1,ACHSTYPE,DA,X2,ZTSK

 D ERPT^ACHS

HDR ; Print header.

 S ACHSPG=ACHSPG+1,ACHST2="PRIORITY: "_ACHSTYPE_"   (page "_ACHSPG_")"

 W @IOF,!!,$$C^XBFUNC("***  CONTRACT HEALTH CARE SYSTEM REPORT  ***",80),!!,ACHSLOC,!,$$C^XBFUNC("DENIAL SYSTEM - UNMET NEEDS LIST",80),!,ACHSTIME

 W !!,ACHST1,!!?80-$L(ACHST2)\2,ACHST2,!!,"TYPE OF UNMET NEED",!?2,"ISSUE DATE",?16,"DENIAL #",?29,"PATIENT",?70,"DOLLARS",!,ACHS("="),!

ACHSDNU2  ; IHS/ITSC/PMF - DENIAL UNMET NEED LIST (3/3) ; [ 10/16/2001   8:16 AM ]

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

 +2        SET $PIECE(^TMP("ACHSDNU",$JOB,0),U,1,2)="^ACHSDNU2"

 +3        KILL ^TMP("ACHSDNU",$JOB,0,"ACHSQIO")

 +4        IF '$DATA(^DD(9002071.01,400,0))!'$DATA(^DD(9002071.01,420,0))

               GOTO K

 +5        SET ACHS=$PIECE(^DD(9002071.01,400,0),U,3)

           FOR ACHS(1)=1:1

               IF $PIECE(ACHS,";",ACHS(1))=""

                   QUIT

               SET ACHS(2)=$PIECE(ACHS,";",ACHS(1))

               SET ACHS("UN",$PIECE(ACHS(2),":"))=$PIECE(ACHS(2),":",2)

 +6       ;S ACHS=$P(^DD(9002071,420,0),U,3) F ACHS(1)=1:1 Q:$P(ACHS,";",ACHS(1))=""  S ACHS(2)=$P(ACHS,";",ACHS(1)),ACHS("CATG",$P(ACHS(2),":"))=$P(ACHS(2),":",2)

 +7       ;GET MEDICAL CATEGORIES FROM CHS MEDICAL PRIORITIES

 +8       ;

 +9        SET MEDPRI=0

FOR

               SET MEDPRI=$ORDER(^ACHSMPRI(MEDPRI))

               IF +MEDPRI=0

                   QUIT

               Begin DoDot:1

 +10               SET MEDPRI0=$GET(^ACHSMPRI(MEDPRI,0))

 +11               SET ACHS("CATG",MEDPRI)=$PIECE(MEDPRI0,U,2)

               End DoDot:1

 +12      ;

 +13      ;

 +14       SET ACHSCAT=""

           SET (ACHSTOT,ACHSDOL)=0

 +15       SET Y=ACHSBDT

           XECUTE ^DD("DD")

           SET ACHS("BDT")=Y

           SET Y=ACHSEDT

           XECUTE ^DD("DD")

           SET ACHS("EDT")=Y

           SET ACHST1=$$C^XBFUNC("For the period "_ACHS("BDT")_" through "_ACHS("EDT"),80)

 +16       DO BRPT^ACHSFU

A         ;

 +1       ;

 +2        SET ACHSCAT=$ORDER(^TMP("ACHSUN",$JOB,ACHSCAT))

           IF ACHSCAT=""&$DATA(ACHSTYPE)

               DO CTOTAL

           IF ACHSCAT=""

               GOTO END1

           IF $DATA(ACHSTOT1)

               DO CTOTAL

           SET ACHSTYPE=ACHS("CATG",ACHSCAT)

           SET (ACHSTOT1,ACHSTOT1("$"))=0

           DO HDR

           SET ACHSNEED=""

B          SET ACHSNEED=$ORDER(^TMP("ACHSUN",$JOB,ACHSCAT,ACHSNEED))

           IF ACHSNEED=""

               GOTO A

           IF $Y>ACHSBM

               DO RTRN^ACHS

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

                   GOTO K

               DO HDR

 +1        SET ACHSISDT=0

           WRITE !,ACHS("UN",ACHSNEED),!

           FOR ACHS=1:1:$LENGTH(ACHS("UN",ACHSNEED))

               WRITE "-"

 +2        WRITE !

C         ;

 +1        SET ACHSISDT=$ORDER(^TMP("ACHSUN",$JOB,ACHSCAT,ACHSNEED,ACHSISDT))

           IF +ACHSISDT=0

               GOTO B

           SET ACHSNAME=""

D         ;

 +1        SET ACHSNAME=$ORDER(^TMP("ACHSUN",$JOB,ACHSCAT,ACHSNEED,ACHSISDT,ACHSNAME))

           IF ACHSNAME=""

               GOTO C

           SET DA=0

E         ;

 +1        SET DA=$ORDER(^TMP("ACHSUN",$JOB,ACHSCAT,ACHSNEED,ACHSISDT,ACHSNAME,DA))

           IF +DA=0

               GOTO D

           SET ACHS("T$")=+^(DA)

           SET ACHSDNUM=$PIECE(^ACHSDEN(DUZ(2),"D",DA,0),U)

 +2        SET Y=ACHSISDT

           XECUTE ^DD("DD")

           WRITE "  ",Y,?16,ACHSDNUM,?29,ACHSNAME,?70,$JUSTIFY(ACHS("T$"),6,2),!

           IF $Y>ACHSBM

               DO RTRN^ACHS

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

                   GOTO K

               DO HDR

 +3        SET ACHSTOT=ACHSTOT+1

           SET ACHSTOT1=ACHSTOT1+1

           SET ACHSTOT1("$")=ACHSTOT1("$")+ACHS("T$")

           SET ACHSDOL=ACHSDOL+ACHS("T$")

 +4        GOTO E

CTOTAL    ;

 +1        SET X=ACHSTOT1("$")

           SET X2="2$"

           DO COMMA^%DTC

           WRITE !,ACHS("="),!!,"TOTALS FOR ",ACHSTYPE,":  ",ACHSTOT1," DENIAL",$SELECT(ACHSTOT1>1:"S",1:""),?65,X

 +2        QUIT

 +3       ;

END1      ; Print totals.

 +1        IF ACHSPG=0

               WRITE "Facility UN-MET NEED list for ",ACHSLOC,!!!,"(No un-met needs were recorded during this time period.)"

               GOTO END2

 +2        SET X=ACHSDOL

           SET X2="2$"

           DO COMMA^%DTC

           WRITE !,ACHS("="),!!!,"TOTAL DENIALS ON THIS REPORT: ",ACHSTOT," DENIAL",$SELECT(ACHSTOT>1:"S",1:""),?65,X

 +3       ;

END2      ; Ask RTRN, write IOF, kill vars, do ERPT, quit.

 +1        DO RTRN^ACHS

           WRITE @IOF

 +2       ;

K          KILL ACHSCAT,ACHSDNUM,ACHSDOL,ACHSISDT,ACHSNAME,ACHSNEED,ACHSTOT,ACHSTOT1,ACHSTYPE,DA,X2,ZTSK

 +1        DO ERPT^ACHS

 +2        QUIT

 +3       ;

HDR       ; Print header.

 +1        SET ACHSPG=ACHSPG+1

           SET ACHST2="PRIORITY: "_ACHSTYPE_"   (page "_ACHSPG_")"

 +2        WRITE @IOF,!!,$$C^XBFUNC("***  CONTRACT HEALTH CARE SYSTEM REPORT  ***",80),!!,ACHSLOC,!,$$C^XBFUNC("DENIAL SYSTEM - UNMET NEEDS LIST",80),!,ACHSTIME

 +3        WRITE !!,ACHST1,!!?80-$LENGTH(ACHST2)\2,ACHST2,!!,"TYPE OF UNMET NEED",!?2,"ISSUE DATE",?16,"DENIAL #",?29,"PATIENT",?70,"DOLLARS",!,ACHS("="),!

 +4        QUIT

ACHSDNU2.m