AG3RDP.m

AG3RDP ;IHS/ASDS/SDH - COUNT 3RD PARTY RESOURCE PATIENTS ;  

 ;;7.1;IHS PATIENT REGISTRATION;**2,4**;JAN 31, 2007

 ;

INTRO ;

 ;;

 ;;3RD PARTY ELIGIBLITY COUNT PROCESS!

 ;;-----------------------------------

 ;;This report counts the number of patients that have 3rd Party

 ;;insurance on a selected date.

 ;; 

 ;;###

 W @IOF

 F AG=1:1 W $$CJ^XLFSTR($P($T(INTRO+AG),";",3),IOM) Q:$P($T(INTRO+AG+1),";",3)="###"

 ;

DATE ; Input date to check for eligibility.

 S AGDT=$$DIR^XBDIR("D","Date for the point in Time you want eligibility for")

 I $D(DIRUT) D EOJ Q

VSTCK ; Input check-active flag.

 S AGVCK=$$DIR^XBDIR("Y","Want to check if patient is active")

 I $D(DIRUT) D EOJ Q

DEV ; Select Device.

 W !!

 KILL IOP

 S %ZIS="PQ"

 KILL IO("Q")

 D ^%ZIS

 I POP D EOJ Q

 I $D(IO("Q")) D TASK,EOJ Q

START ;EP - From TaskMan.

 ;AG*7.1*2 ALPHA ISSUE ADD DATE/TIME STAMP TO AID IN BEFORE/AFTER COMPARISONS FOR CMS DOWNLOAD

 N AGNOW

 D NOW^%DTC

 S Y=% X ^DD("DD")

 S AGNOW=Y

 ;AG*7.1*2 END

 KILL ^TMP("AG3RDP",$J)

 D MCR,MCD,PI,RPT,EOJ

 Q

 ;

MCR ; Process MediCare file.  Record the counts

 I '$D(ZTQUEUED),$E(IOST)="C" U IO(0) W !,"Processing Medicare......"

 S DFN=0

 F  S DFN=$O(^AUPNMCR(DFN)) Q:+DFN=0  D

 . I $P($G(^DPT(DFN,.35)),U)'="",($P($G(^DPT(DFN,.35)),U)'>AGDT) Q

 . S AGM=0

 . F  S AGM=$O(^AUPNMCR(DFN,11,AGM)) Q:+AGM=0  D

 .. S AGST=$P($G(^AUPNMCR(DFN,11,AGM,0)),U)

 .. S AGEND=$P($G(^AUPNMCR(DFN,11,AGM,0)),U,2)

 .. S AGTY=$P($G(^AUPNMCR(DFN,11,AGM,0)),U,3)

 .. S AG("MCR")="N"

 .. I (AGDT'<AGST),(AGEND="") S AG("MCR")="Y"

 .. E  I (AGDT'<AGST),(AGDT'>AGEND) S AG("MCR")="Y"

 .. ;I AG("MCR")="Y" S $P(^TMP("AG3RDP",$J,DFN),U,$S(AGTY="B":4,1:3))=1

 .. I AG("MCR")="Y" S $P(^TMP("AG3RDP",$J,DFN),U,$S(AGTY="B":4,AGTY="A":3,1:5))=1  ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PG 11

 ..Q

 .Q

 Q

 ;

MCD ; Process MediCaid file.  Record the counts

 I '$D(ZTQUEUED),$E(IOST)="C" U IO(0) W !!,"Processing Medicaid...."

 S AG=0

 F  S AG=$O(^AUPNMCD(AG)) Q:+AG=0  D

 . S DFN=$P($G(^AUPNMCD(AG,0)),U)

 . I 'DFN W !,DFN

 . Q:'DFN

 . I $P($G(^DPT(DFN,.35)),U)'="",($P($G(^DPT(DFN,.35)),U)'>AGDT) Q

 . S AGM=0,AG("MCD")="N"

 . F  S AGM=$O(^AUPNMCD(AG,11,AGM)) Q:+AGM=0  D  Q:AG("MCD")="Y"

 .. S AGST=$P($G(^AUPNMCD(AG,11,AGM,0)),U)

 .. S AGEND=$P($G(^AUPNMCD(AG,11,AGM,0)),U,2)

 .. I $E(AGEND,6,7)="00" S AGEND=AGEND+31

 .. I (AGDT'<AGST),(AGEND="") S AG("MCD")="Y"

 .. E  I (AGDT'<AGST),(AGDT'>AGEND) S AG("MCD")="Y"

 .. I AG("MCD")="Y" S $P(^TMP("AG3RDP",$J,DFN),U,1)=1

 ..Q

 .Q

 Q

 ;

PI ; Process Private Insurance file.  Record the counts

 I '$D(ZTQUEUED),$E(IOST)="C" U IO(0) W !!,"Processing Private Ins......."

 S DFN=0

 F  S DFN=$O(^AUPNPRVT(DFN)) Q:+DFN=0  I $$PI^AUPNPAT(DFN,AGDT) S $P(^TMP("AG3RDP",$J,DFN),U,2)=1

 Q

 ;

RPT ;

 K AGST,AGEND,AG,AGM,DIR

 U IO

 D EN

 Q

 ;

EOJ ;

 D ^%ZISC

 K AGDT,AGST,AGTY,AGVCK,DIR,DFN

 K ^TMP("AG3RDP",$J)

 Q

 ;

TASK ;

 K ZTSAVE

 S ZTSAVE("AGDT")="",ZTSAVE("AGVCK")="",ZTIO=ION,ZTRTN="START^AG3RDP",ZTDTH="",ZTDESC="3RD PARTY ELIGIBILITY REPORT"

 D ^%ZTLOAD

 Q

 ;

EN ;

 S (AG,AGMCD,AGPI,AGMCR,AGMCRB,AGMMPI,AGMM,AGMDPI,AGMRPI,AGMCRAB)=0

 S AGMCRD=0  ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

 S AG("BDT")=9999999-(AGDT-30001),AG("EDT")=9999999-(AGDT-1)

 S DFN=0

 F  S DFN=$O(^TMP("AG3RDP",$J,DFN)) Q:+DFN=0  D

 .I $G(AGVCK)=1 D VCHK Q:AG("V")="N"

 .S AG=$G(^TMP("AG3RDP",$J,DFN))

 .;F %=1:1:4 S @("AG"_%)=+$P(AG,U,%)

 .F %=1:1:5 S @("AG"_%)=+$P(AG,U,%)  ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

 .;I AG1=0,AG2=0,AG3=0,AG4=0,AG5=1 S AGMCRD=AGMCRD+1 Q

 .I AG5=1 S AGMCRD=AGMCRD+1 Q  ;AG*7.1*2 ITEM 8 PAGE 11 SPECS CHANGED PER BPD MEETING OF 8/18/2006

 .I AG1=1,AG2=0,AG3=0,AG4=0 S AGMCD=AGMCD+1 Q

 .I AG1=0,AG2=1,AG3=0,AG4=0 S AGPI=AGPI+1 Q

 .I AG1=0,AG2=0,AG3=1,AG4=0 S AGMCR=AGMCR+1 Q

 .I AG1=0,AG2=0,AG3=0,AG4=1 S AGMCRB=AGMCRB+1 Q

 .I AG1=0,AG2=0,AG3=1,AG4=1 S AGMCRAB=AGMCRAB+1 Q

 .I AG1=1,AG2=1,((AG3=1)!(AG4=1)) S AGMMPI=AGMMPI+1 Q

 .I AG1=1,((AG3=1)!(AG4=1)) S AGMM=AGMM+1 Q

 .I AG1=1,AG2=1 S AGMDPI=AGMDPI+1 Q

 .I AG1=0,AG2=1,((AG3=1)!(AG4=1)) S AGMRPI=AGMRPI+1 Q

 .Q

REPORT ;

 U IO

 W !!?10,"3rd Party eligibility Stats"

 W !?10,"For Patients with Eligibility: ",$$FMTE^XLFDT(AGDT)

 W:$G(AGVCK)=1 !?10,"and having a visit in the past 3 years."

 W !?10,"Report Date/Time: ",$G(AGNOW)  ;AG*7.1*2 ALPHA ISSUE ADD DATE/TIME STAMP TO AID IN BEFORE/AFTER COMPARISONS FOR CMS DOWNLOAD 

 W !!?16,"UNDUPLICATED PATIENT COUNTS"

 W !!?10,"Medicaid Only: ",?40,$J(AGMCD,6)

 W !!?10,"Private Insurance Only: ",?40,$J(AGPI,6)

 W !!?10,"Medicare A Only: ",?40,$J(AGMCR,6)

 W !!?10,"Medicare B Only: ",?40,$J(AGMCRB,6)

 W !!?10,"Medicare Part A & B Only: ",?40,$J(AGMCRAB,6)

 W !!?10,"Medicare Part D: ",?40,$J(AGMCRD,6)  ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

 W !!?10,"Medicaid & Medicare: ",?40,$J(AGMM,6)

 W !!?10,"Medicaid & Private Ins.: ",?40,$J(AGMDPI,6)

 W !!?10,"Medicare & Private Ins.: ",?40,$J(AGMRPI,6)

 W !!?10,"Medicaid, Medicare, & PI: ",?40,$J(AGMMPI,6)

 ;S AGTOT=AGMCD+AGPI+AGMCR+AGMCRB+AGMCRAB+AGMM+AGMDPI+AGMRPI+AGMMPI

 S AGTOT=AGMCD+AGPI+AGMCR+AGMCRB+AGMCRAB+AGMM+AGMDPI+AGMRPI+AGMMPI+AGMCRD  ;AG*7.1*4 IM26255

 W !?40,"------",!!?20,"TOTAL",?40,$J(AGTOT,6)

 I '$D(ZTQUEUED),$E(IOST)="C",$$DIR^XBDIR("E","Enter RETURN to continue")

 W @IOF

 D ^%ZISC

 K DFN,AG1,AG2,AG3,AG4,AG,AGTOT,AGMCD,AGPI,AGMCR,AGMCRB,AGMMPI,AGMM,AGMDPI,AGMRPI,AGMCRAB,AGDT

 Q

 ;

VCHK ;

 S AG("V")="N",AGST=0

 F  S AGST=$O(^AUPNVSIT("AA",DFN,AGST)) Q:AGST=""  I (AGST<AG("BDT")),(AGST>AG("EDT")) S AG("V")="Y" Q

 Q

AG3RDP    ;IHS/ASDS/SDH - COUNT 3RD PARTY RESOURCE PATIENTS ;  

 +1       ;;7.1;IHS PATIENT REGISTRATION;**2,4**;JAN 31, 2007

 +2       ;

INTRO     ;

 +1       ;;

 +2       ;;3RD PARTY ELIGIBLITY COUNT PROCESS!

 +3       ;;-----------------------------------

 +4       ;;This report counts the number of patients that have 3rd Party

 +5       ;;insurance on a selected date.

 +6       ;; 

 +7       ;;###

 +8        WRITE @IOF

 +9        FOR AG=1:1

               WRITE $$CJ^XLFSTR($PIECE($TEXT(INTRO+AG),";",3),IOM)

               IF $PIECE($TEXT(INTRO+AG+1),";",3)="###"

                   QUIT 

 +10      ;

DATE      ; Input date to check for eligibility.

 +1        SET AGDT=$$DIR^XBDIR("D","Date for the point in Time you want eligibility for")

 +2        IF $DATA(DIRUT)

               DO EOJ

               QUIT 

VSTCK     ; Input check-active flag.

 +1        SET AGVCK=$$DIR^XBDIR("Y","Want to check if patient is active")

 +2        IF $DATA(DIRUT)

               DO EOJ

               QUIT 

DEV       ; Select Device.

 +1        WRITE !!

 +2        KILL IOP

 +3        SET %ZIS="PQ"

 +4        KILL IO("Q")

 +5        DO ^%ZIS

 +6        IF POP

               DO EOJ

               QUIT 

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

               DO TASK

               DO EOJ

               QUIT 

START     ;EP - From TaskMan.

 +1       ;AG*7.1*2 ALPHA ISSUE ADD DATE/TIME STAMP TO AID IN BEFORE/AFTER COMPARISONS FOR CMS DOWNLOAD

 +2        NEW AGNOW

 +3        DO NOW^%DTC

 +4        SET Y=%

           XECUTE ^DD("DD")

 +5        SET AGNOW=Y

 +6       ;AG*7.1*2 END

 +7        KILL ^TMP("AG3RDP",$JOB)

 +8        DO MCR

           DO MCD

           DO PI

           DO RPT

           DO EOJ

 +9        QUIT 

 +10      ;

MCR       ; Process MediCare file.  Record the counts

 +1        IF '$DATA(ZTQUEUED)

               IF $EXTRACT(IOST)="C"

                   USE IO(0)

                   WRITE !,"Processing Medicare......"

 +2        SET DFN=0

 +3        FOR 

               SET DFN=$ORDER(^AUPNMCR(DFN))

               IF +DFN=0

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE($GET(^DPT(DFN,.35)),U)'=""

                       IF ($PIECE($GET(^DPT(DFN,.35)),U)'>AGDT)

                           QUIT 

 +5                SET AGM=0

 +6                FOR 

                       SET AGM=$ORDER(^AUPNMCR(DFN,11,AGM))

                       IF +AGM=0

                           QUIT 

                       Begin DoDot:2

 +7                        SET AGST=$PIECE($GET(^AUPNMCR(DFN,11,AGM,0)),U)

 +8                        SET AGEND=$PIECE($GET(^AUPNMCR(DFN,11,AGM,0)),U,2)

 +9                        SET AGTY=$PIECE($GET(^AUPNMCR(DFN,11,AGM,0)),U,3)

 +10                       SET AG("MCR")="N"

 +11                       IF (AGDT'<AGST)

                               IF (AGEND="")

                                   SET AG("MCR")="Y"

 +12                      IF '$TEST

                               IF (AGDT'<AGST)

                                   IF (AGDT'>AGEND)

                                       SET AG("MCR")="Y"

 +13      ;I AG("MCR")="Y" S $P(^TMP("AG3RDP",$J,DFN),U,$S(AGTY="B":4,1:3))=1

 +14      ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PG 11

                           IF AG("MCR")="Y"

                               SET $PIECE(^TMP("AG3RDP",$JOB,DFN),U,$SELECT(AGTY="B":4,AGTY="A":3,1:5))=1

 +15                       QUIT 

                       End DoDot:2

 +16               QUIT 

               End DoDot:1

 +17       QUIT 

 +18      ;

MCD       ; Process MediCaid file.  Record the counts

 +1        IF '$DATA(ZTQUEUED)

               IF $EXTRACT(IOST)="C"

                   USE IO(0)

                   WRITE !!,"Processing Medicaid...."

 +2        SET AG=0

 +3        FOR 

               SET AG=$ORDER(^AUPNMCD(AG))

               IF +AG=0

                   QUIT 

               Begin DoDot:1

 +4                SET DFN=$PIECE($GET(^AUPNMCD(AG,0)),U)

 +5                IF 'DFN

                       WRITE !,DFN

 +6                IF 'DFN

                       QUIT 

 +7                IF $PIECE($GET(^DPT(DFN,.35)),U)'=""

                       IF ($PIECE($GET(^DPT(DFN,.35)),U)'>AGDT)

                           QUIT 

 +8                SET AGM=0

                   SET AG("MCD")="N"

 +9                FOR 

                       SET AGM=$ORDER(^AUPNMCD(AG,11,AGM))

                       IF +AGM=0

                           QUIT 

                       Begin DoDot:2

 +10                       SET AGST=$PIECE($GET(^AUPNMCD(AG,11,AGM,0)),U)

 +11                       SET AGEND=$PIECE($GET(^AUPNMCD(AG,11,AGM,0)),U,2)

 +12                       IF $EXTRACT(AGEND,6,7)="00"

                               SET AGEND=AGEND+31

 +13                       IF (AGDT'<AGST)

                               IF (AGEND="")

                                   SET AG("MCD")="Y"

 +14                      IF '$TEST

                               IF (AGDT'<AGST)

                                   IF (AGDT'>AGEND)

                                       SET AG("MCD")="Y"

 +15                       IF AG("MCD")="Y"

                               SET $PIECE(^TMP("AG3RDP",$JOB,DFN),U,1)=1

 +16                       QUIT 

                       End DoDot:2

                       IF AG("MCD")="Y"

                           QUIT 

 +17               QUIT 

               End DoDot:1

 +18       QUIT 

 +19      ;

PI        ; Process Private Insurance file.  Record the counts

 +1        IF '$DATA(ZTQUEUED)

               IF $EXTRACT(IOST)="C"

                   USE IO(0)

                   WRITE !!,"Processing Private Ins......."

 +2        SET DFN=0

 +3        FOR 

               SET DFN=$ORDER(^AUPNPRVT(DFN))

               IF +DFN=0

                   QUIT 

               IF $$PI^AUPNPAT(DFN,AGDT)

                   SET $PIECE(^TMP("AG3RDP",$JOB,DFN),U,2)=1

 +4        QUIT 

 +5       ;

RPT       ;

 +1        KILL AGST,AGEND,AG,AGM,DIR

 +2        USE IO

 +3        DO EN

 +4        QUIT 

 +5       ;

EOJ       ;

 +1        DO ^%ZISC

 +2        KILL AGDT,AGST,AGTY,AGVCK,DIR,DFN

 +3        KILL ^TMP("AG3RDP",$JOB)

 +4        QUIT 

 +5       ;

TASK      ;

 +1        KILL ZTSAVE

 +2        SET ZTSAVE("AGDT")=""

           SET ZTSAVE("AGVCK")=""

           SET ZTIO=ION

           SET ZTRTN="START^AG3RDP"

           SET ZTDTH=""

           SET ZTDESC="3RD PARTY ELIGIBILITY REPORT"

 +3        DO ^%ZTLOAD

 +4        QUIT 

 +5       ;

EN        ;

 +1        SET (AG,AGMCD,AGPI,AGMCR,AGMCRB,AGMMPI,AGMM,AGMDPI,AGMRPI,AGMCRAB)=0

 +2       ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

           SET AGMCRD=0

 +3        SET AG("BDT")=9999999-(AGDT-30001)

           SET AG("EDT")=9999999-(AGDT-1)

 +4        SET DFN=0

 +5        FOR 

               SET DFN=$ORDER(^TMP("AG3RDP",$JOB,DFN))

               IF +DFN=0

                   QUIT 

               Begin DoDot:1

 +6                IF $GET(AGVCK)=1

                       DO VCHK

                       IF AG("V")="N"

                           QUIT 

 +7                SET AG=$GET(^TMP("AG3RDP",$JOB,DFN))

 +8       ;F %=1:1:4 S @("AG"_%)=+$P(AG,U,%)

 +9       ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

                   FOR %=1:1:5

                       SET @("AG"_%)=+$PIECE(AG,U,%)

 +10      ;I AG1=0,AG2=0,AG3=0,AG4=0,AG5=1 S AGMCRD=AGMCRD+1 Q

 +11      ;AG*7.1*2 ITEM 8 PAGE 11 SPECS CHANGED PER BPD MEETING OF 8/18/2006

                   IF AG5=1

                       SET AGMCRD=AGMCRD+1

                       QUIT 

 +12               IF AG1=1

                       IF AG2=0

                           IF AG3=0

                               IF AG4=0

                                   SET AGMCD=AGMCD+1

                                   QUIT 

 +13               IF AG1=0

                       IF AG2=1

                           IF AG3=0

                               IF AG4=0

                                   SET AGPI=AGPI+1

                                   QUIT 

 +14               IF AG1=0

                       IF AG2=0

                           IF AG3=1

                               IF AG4=0

                                   SET AGMCR=AGMCR+1

                                   QUIT 

 +15               IF AG1=0

                       IF AG2=0

                           IF AG3=0

                               IF AG4=1

                                   SET AGMCRB=AGMCRB+1

                                   QUIT 

 +16               IF AG1=0

                       IF AG2=0

                           IF AG3=1

                               IF AG4=1

                                   SET AGMCRAB=AGMCRAB+1

                                   QUIT 

 +17               IF AG1=1

                       IF AG2=1

                           IF ((AG3=1)!(AG4=1))

                               SET AGMMPI=AGMMPI+1

                               QUIT 

 +18               IF AG1=1

                       IF ((AG3=1)!(AG4=1))

                           SET AGMM=AGMM+1

                           QUIT 

 +19               IF AG1=1

                       IF AG2=1

                           SET AGMDPI=AGMDPI+1

                           QUIT 

 +20               IF AG1=0

                       IF AG2=1

                           IF ((AG3=1)!(AG4=1))

                               SET AGMRPI=AGMRPI+1

                               QUIT 

 +21               QUIT 

               End DoDot:1

REPORT    ;

 +1        USE IO

 +2        WRITE !!?10,"3rd Party eligibility Stats"

 +3        WRITE !?10,"For Patients with Eligibility: ",$$FMTE^XLFDT(AGDT)

 +4        IF $GET(AGVCK)=1

               WRITE !?10,"and having a visit in the past 3 years."

 +5       ;AG*7.1*2 ALPHA ISSUE ADD DATE/TIME STAMP TO AID IN BEFORE/AFTER COMPARISONS FOR CMS DOWNLOAD 

           WRITE !?10,"Report Date/Time: ",$GET(AGNOW)

 +6        WRITE !!?16,"UNDUPLICATED PATIENT COUNTS"

 +7        WRITE !!?10,"Medicaid Only: ",?40,$JUSTIFY(AGMCD,6)

 +8        WRITE !!?10,"Private Insurance Only: ",?40,$JUSTIFY(AGPI,6)

 +9        WRITE !!?10,"Medicare A Only: ",?40,$JUSTIFY(AGMCR,6)

 +10       WRITE !!?10,"Medicare B Only: ",?40,$JUSTIFY(AGMCRB,6)

 +11       WRITE !!?10,"Medicare Part A & B Only: ",?40,$JUSTIFY(AGMCRAB,6)

 +12      ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 8 PAGE 11

           WRITE !!?10,"Medicare Part D: ",?40,$JUSTIFY(AGMCRD,6)

 +13       WRITE !!?10,"Medicaid & Medicare: ",?40,$JUSTIFY(AGMM,6)

 +14       WRITE !!?10,"Medicaid & Private Ins.: ",?40,$JUSTIFY(AGMDPI,6)

 +15       WRITE !!?10,"Medicare & Private Ins.: ",?40,$JUSTIFY(AGMRPI,6)

 +16       WRITE !!?10,"Medicaid, Medicare, & PI: ",?40,$JUSTIFY(AGMMPI,6)

 +17      ;S AGTOT=AGMCD+AGPI+AGMCR+AGMCRB+AGMCRAB+AGMM+AGMDPI+AGMRPI+AGMMPI

 +18      ;AG*7.1*4 IM26255

           SET AGTOT=AGMCD+AGPI+AGMCR+AGMCRB+AGMCRAB+AGMM+AGMDPI+AGMRPI+AGMMPI+AGMCRD

 +19       WRITE !?40,"------",!!?20,"TOTAL",?40,$JUSTIFY(AGTOT,6)

 +20       IF '$DATA(ZTQUEUED)

               IF $EXTRACT(IOST)="C"

                   IF $$DIR^XBDIR("E","Enter RETURN to continue")

 +21       WRITE @IOF

 +22       DO ^%ZISC

 +23       KILL DFN,AG1,AG2,AG3,AG4,AG,AGTOT,AGMCD,AGPI,AGMCR,AGMCRB,AGMMPI,AGMM,AGMDPI,AGMRPI,AGMCRAB,AGDT

 +24       QUIT 

 +25      ;

VCHK      ;

 +1        SET AG("V")="N"

           SET AGST=0

 +2        FOR 

               SET AGST=$ORDER(^AUPNVSIT("AA",DFN,AGST))

               IF AGST=""

                   QUIT 

               IF (AGST<AG("BDT"))

                   IF (AGST>AG("EDT"))

                       SET AG("V")="Y"

                       QUIT 

 +3        QUIT