Routine: AGMCRP4

AGMCRP4 ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE PART D ;

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

 ;;;MODIFIED FROM AGMCRP3

 S AGIO=IO,AG("HAT")=""

PTS ;

 S DIR(0)="S^B:ALL BENEFICIARIES;A:ACTIVE PATIENTS ONLY;D:DECEASED AND INACTIVE PATIENTS ONLY"

 S DIR("A")="SELECT DESIRED ACCOUNTS"

 D ^DIR K DIR

 S AGPTS=Y

 Q:$D(DTOUT)!(Y="^")!(Y="/.,")!(Y="^^")

DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q

 G:'$D(IO("Q")) START

 K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV

 X ^%ZOSF("UCI")

 S ZTRTN="START^AGMCRP",ZTUCI=Y,ZTIO=""

 S ZTDESC="Alpha List MEDICARE/RR Holders for "_$P(^AUTTLOC(DUZ(2),0),U,2)_"."

 S AGQIO=IO F G="AGQIO" S ZTSAVE(G)=""

 D ^%ZTLOAD

 G:'$D(ZTSK) DEV

 K AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI

 D ^%ZISC

START ;EP - From TaskMan.

 S (DFN,AGTOT,AGTOTAL)=0 K ^TMP($J)

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

 .S AGFLAG=0

 .;if there is an HRN for this person and data in VA PATIENT

 .I $D(^AUPNPAT(DFN,41,DUZ(2))),$D(^DPT(DFN,0)) D

 ..I AGPTS="A" D   ;active people only

 ...I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)="",$P($G(^DPT(DFN,.35)),U)="" S AGFLAG=1

 ..I AGPTS="D" D   ;deceased/inactive only

 ...I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'=""!($P($G(^DPT(DFN,.35)),U)'="") S AGFLAG=1

 ..I AGPTS="B" S AGFLAG=1

 ..I AGFLAG S ^TMP($J,$P(^DPT(DFN,0),U),DFN)="",AGTOT=AGTOT+1

 I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP  H 30

 X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",",1)

 D CTR^AG

 S AGUCI=X,AGPGPG=0,AG("LOC")=$P(^DIC(4,DUZ(2),0),U)

 S AG("USR")=$P(^VA(200,DUZ,0),U)

 S AG("USRLOC")=AG("USR")_$J("",40-($L(AG("LOC"))\2)-$L(AG("USR")))_AG("LOC"),AGBM=IOSL-10

 I $D(AGIO),AGIO=IO S AGBM=IOSL-4

 K AG("LOC"),AG("USR")

 D LINES^AG,NOW^AG

 S AGNM="",X="as of "_AGTIME D CTR^AG S AGTIME=X U IO D HDR

 F AGZ("I")=1:1 S AGNM=$O(^TMP($J,AGNM)) Q:AGNM=""  S DFN=0 F AGZ("I")=1:1 S DFN=$O(^TMP($J,AGNM,DFN)) Q:DFN=""  D PRINT I $Y>AGBM D RTRN^AG G END1:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) D HDR

END W !!!,"TOTAL MEDICARE/RAILROAD RET. PATIENTS: ",AGTOT K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")

 ;W !!!,"TOTAL MEDICARE/RAILROAD RET. PATIENTS: ",AGTOTAL K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")

END1 D ^%ZISC K ^TMP($J),A,AG,AGBM,AGDOB,AGIO,AGTIME,DA,AG("DENT"),DIC,DFN,DR,G,AGL,I,AG("LKDATA"),AG("LKPRINT"),AGNEW,AGNM,AGPCC,AGPGPG,AGTOT,AGUCI,AG("USRLOC"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD

PRINT ;Print a Patient's MEDICARE/RAILROAD file.

 ;this is to make sure they are Part D somewhere

 S (I,AGCFLAG)=""

 F  S I=$O(^AUPNMCR(DFN,11,I)) Q:I=""  D

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

 .I AGCOV="D" S AGCFLAG=1

 .Q:AGCOV'="D"

 .S AGTOTAL=AGTOTAL+1

 .S AGMCRBD=$P($G(^AUPNMCR(DFN,11,I,0)),U)

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

 .;Q:'$$ISACTIVE^AGUTILS(AGMCRBD,AGMCRED)

 .S Y=AGMCRBD X ^DD("DD") S AGMCRBD=Y

 .S Y=AGMCRED X ^DD("DD") S AGMCRED=Y

 .S AGMCRPN=$P($G(^AUPNMCR(DFN,11,I,0)),U,4)

 .S:AGMCRPN'="" AGMCRPN=$P($G(^AUTNINS(AGMCRPN,0)),U)

 .S AGMCRNM=$P($G(^AUPNMCR(DFN,11,I,0)),U,5)

 .S AGMCRNO=$P($G(^AUPNMCR(DFN,11,I,0)),U,6)

 .S AGMCRDB=$P($G(^AUPNMCR(DFN,11,I,0)),U,9) S Y=AGMCRDB X ^DD("DD") S AGMCRDB=Y

 .S DIC=2,DA=DFN,DR=.03 D ^AGDICLK K AGDOB S:$D(AG("LKPRINT")) AGDOB=AG("LKPRINT")

 .W "(REG) ",AGNM,?36,$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?49

 .;G RR:^TMP($J,AGNM,DFN)="R"

 .W AGMCRNO

 .W ?64,AGDOB

 .W !,"(MCR) ",AGMCRNM W ?64,AGMCRDB

 .W !,"(PLN) ",AGMCRPN

 .W !,"(MCR) ",?15,AGMCRBD,?36,AGCOV,?49,AGMCRED

 .W !,AG("-"),!

 D RR

RR ;

 S (I,AGCFLAG)=""

 F  S I=$O(^AUPNRRE(DFN,11,I)) Q:I=""  D

 .S AGCOV=$P($G(^AUPNRRE(DFN,11,I,0)),U,3)

 .I AGCOV="D" S AGCFLAG=1

 .Q:AGCOV'="D"

 .S AGMCRBD=$P($G(^AUPNRRE(DFN,11,I,0)),U)

 .S AGMCRED=$P($G(^AUPNRRE(DFN,11,I,0)),U,2)

 .;Q:'$$ISACTIVE^AGUTILS(AGMCRBD,AGMCRED)

 .S Y=AGMCRBD X ^DD("DD") S AGMCRBD=Y

 .S Y=AGMCRED X ^DD("DD") S AGMCRED=Y

 .S AGMCRPN=$P($G(^AUPNRRE(DFN,11,I,0)),U,4)

 .S:AGMCRPN'="" AGMCRPN=$P($G(^AUTNINS(AGMCRPN,0)),U)

 .S AGMCRNM=$P($G(^AUPNRRE(DFN,11,I,0)),U,5)

 .S AGMCRNO=$P($G(^AUPNRRE(DFN,11,I,0)),U,6)

 .S AGMCRDB=$P($G(^AUPNRRE(DFN,11,I,0)),U,9) S Y=AGMCRDB X ^DD("DD") S AGMCRDB=Y

 .S DIC=2,DA=DFN,DR=.03 D ^AGDICLK K AGDOB S:$D(AG("LKPRINT")) AGDOB=AG("LKPRINT")

 .W "(REG) ",AGNM,?36,$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?49

 .W AGMCRNO

 .W ?64,AGDOB

 .W !,"(MCR) ",AGMCRNM W ?64,AGMCRDB

 .W !,"(PLN) ",AGMCRPN

 .W !,"(MCR) ",?15,AGMCRBD,?36,AGCOV,?49,AGMCRED

 .W !,AG("-"),!

HDR S AGPGPG=AGPGPG+1

 W $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG

 W !?17,"REGISTERED PATIENTS - MEDICARE/RAILROAD PART D ACCOUNTS"

 W !,AGUCI,!,AGTIME

 W !!?17,"REPORT CONTAINS "_$S(AGPTS="B":"ALL BENEFICIARIES",AGPTS="A":"ACTIVE PATIENTS ONLY",AGPTS="D":"DECEASED AND INACTIVE PATIENTS ONLY")

 W !!?5,"NAME",?36,"CHART #",?49,"NUMBER"

 W !,"(TYPE)",?15,"ELIG DATE",?36,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"

 W !,AG("="),!

AGMCRP4   ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE PART D ;

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

 +2       ;;;MODIFIED FROM AGMCRP3

 +3        SET AGIO=IO

           SET AG("HAT")=""

PTS       ;

 +1        SET DIR(0)="S^B:ALL BENEFICIARIES;A:ACTIVE PATIENTS ONLY;D:DECEASED AND INACTIVE PATIENTS ONLY"

 +2        SET DIR("A")="SELECT DESIRED ACCOUNTS"

 +3        DO ^DIR

           KILL DIR

 +4        SET AGPTS=Y

 +5        IF $DATA(DTOUT)!(Y="^")!(Y="/.,")!(Y="^^")

               QUIT

DEV        SET %ZIS="OPQ"

           DO ^%ZIS

           IF POP

               SET IOP=ION

               DO ^%ZIS

               QUIT

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

               GOTO START

 +2        KILL IO("Q")

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

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

               DO ^%ZISC

               GOTO DEV

 +3        XECUTE ^%ZOSF("UCI")

 +4        SET ZTRTN="START^AGMCRP"

           SET ZTUCI=Y

           SET ZTIO=""

 +5        SET ZTDESC="Alpha List MEDICARE/RR Holders for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."

 +6        SET AGQIO=IO

           FOR G="AGQIO"

               SET ZTSAVE(G)=""

 +7        DO ^%ZTLOAD

 +8        IF '$DATA(ZTSK)

               GOTO DEV

 +9        KILL AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI

 +10       DO ^%ZISC

 +11       QUIT

START     ;EP - From TaskMan.

 +1        SET (DFN,AGTOT,AGTOTAL)=0

           KILL ^TMP($JOB)

 +2        FOR

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

               IF +DFN<1

                   QUIT

               Begin DoDot:1

 +3                SET AGFLAG=0

 +4       ;if there is an HRN for this person and data in VA PATIENT

 +5                IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))

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

                           Begin DoDot:2

 +6       ;active people only

                               IF AGPTS="A"

                                   Begin DoDot:3

 +7                                    IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)=""

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

                                               SET AGFLAG=1

                                   End DoDot:3

 +8       ;deceased/inactive only

                               IF AGPTS="D"

                                   Begin DoDot:3

 +9                                    IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'=""!($PIECE($GET(^DPT(DFN,.35)),U)'="")

                                           SET AGFLAG=1

                                   End DoDot:3

 +10                           IF AGPTS="B"

                                   SET AGFLAG=1

 +11                           IF AGFLAG

                                   SET ^TMP($JOB,$PIECE(^DPT(DFN,0),U),DFN)=""

                                   SET AGTOT=AGTOT+1

                           End DoDot:2

               End DoDot:1

 +12       IF $DATA(AGQIO)

               FOR AGZ("I")=1:1

                   SET IOP=AGQIO

                   DO ^%ZIS

                   IF 'POP

                       QUIT

                   HANG 30

 +13       XECUTE ^%ZOSF("UCI")

           SET X="UCI: "_$PIECE(Y,",",1)

 +14       DO CTR^AG

 +15       SET AGUCI=X

           SET AGPGPG=0

           SET AG("LOC")=$PIECE(^DIC(4,DUZ(2),0),U)

 +16       SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)

 +17       SET AG("USRLOC")=AG("USR")_$JUSTIFY("",40-($LENGTH(AG("LOC"))\2)-$LENGTH(AG("USR")))_AG("LOC")

           SET AGBM=IOSL-10

 +18       IF $DATA(AGIO)

               IF AGIO=IO

                   SET AGBM=IOSL-4

 +19       KILL AG("LOC"),AG("USR")

 +20       DO LINES^AG

           DO NOW^AG

 +21       SET AGNM=""

           SET X="as of "_AGTIME

           DO CTR^AG

           SET AGTIME=X

           USE IO

           DO HDR

 +22       FOR AGZ("I")=1:1

               SET AGNM=$ORDER(^TMP($JOB,AGNM))

               IF AGNM=""

                   QUIT

               SET DFN=0

               FOR AGZ("I")=1:1

                   SET DFN=$ORDER(^TMP($JOB,AGNM,DFN))

                   IF DFN=""

                       QUIT

                   DO PRINT

                   IF $Y>AGBM

                       DO RTRN^AG

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

                           GOTO END1

                       DO HDR

END        WRITE !!!,"TOTAL MEDICARE/RAILROAD RET. PATIENTS: ",AGTOT

           KILL AG("HAT")

           DO RTRN^AG

           WRITE $$S^AGVDF("IOF")

 +1       ;W !!!,"TOTAL MEDICARE/RAILROAD RET. PATIENTS: ",AGTOTAL K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")

END1       DO ^%ZISC

           KILL ^TMP($JOB),A,AG,AGBM,AGDOB,AGIO,AGTIME,DA,AG("DENT"),DIC,DFN,DR,G,AGL,I,AG("LKDATA"),AG("LKPRINT"),AGNEW,AGNM,AGPCC,AGPGPG,AGTOT,AGUCI,AG("USRLOC"),X,Y

           IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +1        QUIT

PRINT     ;Print a Patient's MEDICARE/RAILROAD file.

 +1       ;this is to make sure they are Part D somewhere

 +2        SET (I,AGCFLAG)=""

 +3        FOR

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

               IF I=""

                   QUIT

               Begin DoDot:1

 +4                SET AGCOV=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)

 +5                IF AGCOV="D"

                       SET AGCFLAG=1

 +6                IF AGCOV'="D"

                       QUIT

 +7                SET AGTOTAL=AGTOTAL+1

 +8                SET AGMCRBD=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U)

 +9                SET AGMCRED=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2)

 +10      ;Q:'$$ISACTIVE^AGUTILS(AGMCRBD,AGMCRED)

 +11               SET Y=AGMCRBD

                   XECUTE ^DD("DD")

                   SET AGMCRBD=Y

 +12               SET Y=AGMCRED

                   XECUTE ^DD("DD")

                   SET AGMCRED=Y

 +13               SET AGMCRPN=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,4)

 +14               IF AGMCRPN'=""

                       SET AGMCRPN=$PIECE($GET(^AUTNINS(AGMCRPN,0)),U)

 +15               SET AGMCRNM=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,5)

 +16               SET AGMCRNO=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,6)

 +17               SET AGMCRDB=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,9)

                   SET Y=AGMCRDB

                   XECUTE ^DD("DD")

                   SET AGMCRDB=Y

 +18               SET DIC=2

                   SET DA=DFN

                   SET DR=.03

                   DO ^AGDICLK

                   KILL AGDOB

                   IF $DATA(AG("LKPRINT"))

                       SET AGDOB=AG("LKPRINT")

 +19               WRITE "(REG) ",AGNM,?36,$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?49

 +20      ;G RR:^TMP($J,AGNM,DFN)="R"

 +21               WRITE AGMCRNO

 +22               WRITE ?64,AGDOB

 +23               WRITE !,"(MCR) ",AGMCRNM

                   WRITE ?64,AGMCRDB

 +24               WRITE !,"(PLN) ",AGMCRPN

 +25               WRITE !,"(MCR) ",?15,AGMCRBD,?36,AGCOV,?49,AGMCRED

 +26               WRITE !,AG("-"),!

               End DoDot:1

 +27       DO RR

 +28       QUIT

RR        ;

 +1        SET (I,AGCFLAG)=""

 +2        FOR

               SET I=$ORDER(^AUPNRRE(DFN,11,I))

               IF I=""

                   QUIT

               Begin DoDot:1

 +3                SET AGCOV=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,3)

 +4                IF AGCOV="D"

                       SET AGCFLAG=1

 +5                IF AGCOV'="D"

                       QUIT

 +6                SET AGMCRBD=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U)

 +7                SET AGMCRED=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,2)

 +8       ;Q:'$$ISACTIVE^AGUTILS(AGMCRBD,AGMCRED)

 +9                SET Y=AGMCRBD

                   XECUTE ^DD("DD")

                   SET AGMCRBD=Y

 +10               SET Y=AGMCRED

                   XECUTE ^DD("DD")

                   SET AGMCRED=Y

 +11               SET AGMCRPN=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,4)

 +12               IF AGMCRPN'=""

                       SET AGMCRPN=$PIECE($GET(^AUTNINS(AGMCRPN,0)),U)

 +13               SET AGMCRNM=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,5)

 +14               SET AGMCRNO=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,6)

 +15               SET AGMCRDB=$PIECE($GET(^AUPNRRE(DFN,11,I,0)),U,9)

                   SET Y=AGMCRDB

                   XECUTE ^DD("DD")

                   SET AGMCRDB=Y

 +16               SET DIC=2

                   SET DA=DFN

                   SET DR=.03

                   DO ^AGDICLK

                   KILL AGDOB

                   IF $DATA(AG("LKPRINT"))

                       SET AGDOB=AG("LKPRINT")

 +17               WRITE "(REG) ",AGNM,?36,$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),?49

 +18               WRITE AGMCRNO

 +19               WRITE ?64,AGDOB

 +20               WRITE !,"(MCR) ",AGMCRNM

                   WRITE ?64,AGMCRDB

 +21               WRITE !,"(PLN) ",AGMCRPN

 +22               WRITE !,"(MCR) ",?15,AGMCRBD,?36,AGCOV,?49,AGMCRED

 +23               WRITE !,AG("-"),!

               End DoDot:1

 +24       QUIT

HDR        SET AGPGPG=AGPGPG+1

 +1        WRITE $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG

 +2        WRITE !?17,"REGISTERED PATIENTS - MEDICARE/RAILROAD PART D ACCOUNTS"

 +3        WRITE !,AGUCI,!,AGTIME

 +4        WRITE !!?17,"REPORT CONTAINS "_$SELECT(AGPTS="B":"ALL BENEFICIARIES",AGPTS="A":"ACTIVE PATIENTS ONLY",AGPTS="D":"DECEASED AND INACTIVE PATIENTS ONLY")

 +5        WRITE !!?5,"NAME",?36,"CHART #",?49,"NUMBER"

 +6        WRITE !,"(TYPE)",?15,"ELIG DATE",?36,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"

 +7        WRITE !,AG("="),!

 +8        QUIT

AGMCRP4.m