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
Q
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
Q
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
Q
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("-"),!
Q
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("="),!
Q
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
