AGMCRP6 ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE/MEDICAID HOLDERS ;
;;7.1;PATIENT REGISTRATION;**4,14**;AUG 25,2005;Build 1
;
;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2
;
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^AGMCRP6",ZTUCI=Y,ZTIO="",ZTDESC="Alpha List MEDICARE/MEDICAID Holders for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",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)=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),AG("USR")=$P(^VA(200,DUZ,0),U),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
S AGSTOP=""
F S AGNM=$O(^TMP($J,AGNM)) Q:AGNM="" D Q:AGSTOP
.S DFN=0
.F S DFN=$O(^TMP($J,AGNM,DFN)) Q:DFN="" D Q:AGSTOP
..D PRINT
..I $Y>AGBM D
...D RTRN^AG
...I $D(DUOUT)!$D(DTOUT)!$D(DFOUT) S AGSTOP=1 G END1
...D HDR
I 'AGSTOP D END
Q
END W !!!,"TOTAL MEDICARE A & B PATIENTS: ",AGTOT 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 file.
;DO THEY HAVE BOTH?
Q:'$D(^AUPNMCR(DFN))!('$$MCDDATES(DFN))
W "(REG) ",AGNM,?36,$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
S Y=$$GET1^DIQ(2,DFN_",",.03,"I") X ^DD("DD") W ?64,Y
W !,"(MCR) " W $$GET1^DIQ(9000003,DFN_",",2101)
;W ?49,$$GET1^DIQ(9000003,DFN_",",.03),$$GET1^DIQ(9000003,DFN_",",.04) ;IHS/OIT/NKD AG*7.1*14
W ?49,$$GETMCR^AGUTL(DFN)
W ?64,$$GET1^DIQ(9000003,DFN_",",2102)
S REC=0
F S REC=$O(^AUPNMCR(DFN,11,REC)) Q:'REC D
.W !,"(MCR) " W ?14,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.01)
.W ?37,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.03)
.W ?49,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.02)
;PRINT MCD INFO
S REC=""
F S REC=$O(^AUPNMCD("B",DFN,REC)) Q:'REC D
.S AGMCDNM=$$GET1^DIQ(9000004,REC_",",2101)
.S AGMCDDOB=$$GET1^DIQ(9000004,REC_",",2102)
.S AGMCDNUM=$$GET1^DIQ(9000004,REC_",",.03)
.W !!,"(MCD) ",AGMCDNM,?49,AGMCDNUM,?64,AGMCDDOB
.S ELIGDT=0
.F S ELIGDT=$O(^AUPNMCD(REC,11,ELIGDT)) Q:'ELIGDT D
..W !,"(MCD) "
..W ?14,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.01)
..W ?37,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.03)
..W ?49,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.02)
W !,AG("-"),!
Q
;
MCDDATES(DFN) ;EP - CHECK FOR ANY MCD DATES
N REC,EDT,MCDFLAG
S MCDFLAG=0
S REC=""
F S REC=$O(^AUPNMCD("B",DFN,REC)) Q:'REC D
.S EDT=0
.Q:'$O(^AUPNMCD(REC,11,EDT)) ;NO DATE ENTRIES
.S MCDFLAG=1
Q MCDFLAG
;
HDR S AGPGPG=AGPGPG+1
W $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG
W !?17,"REGISTERED PATIENTS - MEDICARE/MEDICAID 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 !," NAME",?36,"CHART #",?49,"POL. NUMBER",!,"(TYPE)"
W ?14,"ELIG DATE",?34,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"
W !,AG("="),!
Q
AGMCRP6 ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE/MEDICAID HOLDERS ;
+1 ;;7.1;PATIENT REGISTRATION;**4,14**;AUG 25,2005;Build 1
+2 ;
+3 ;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2
+4 ;
+5 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
KILL IO("Q")
IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+2 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGMCRP6"
SET ZTUCI=Y
SET ZTIO=""
SET ZTDESC="Alpha List MEDICARE/MEDICAID Holders for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."
SET AGQIO=IO
FOR G="AGQIO"
SET ZTSAVE(G)=""
+3 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI
DO ^%ZISC
+4 QUIT
START ;EP - From TaskMan.
+1 SET (DFN,AGTOT)=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)
SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)
SET AG("USRLOC")=AG("USR")_$JUSTIFY("",40-($LENGTH(AG("LOC"))\2)-$LENGTH(AG("USR")))_AG("LOC")
SET AGBM=IOSL-10
+16 IF $DATA(AGIO)
IF AGIO=IO
SET AGBM=IOSL-4
+17 KILL AG("LOC"),AG("USR")
DO LINES^AG
DO NOW^AG
SET AGNM=""
SET X="as of "_AGTIME
DO CTR^AG
SET AGTIME=X
USE IO
DO HDR
+18 SET AGSTOP=""
+19 FOR
SET AGNM=$ORDER(^TMP($JOB,AGNM))
IF AGNM=""
QUIT
Begin DoDot:1
+20 SET DFN=0
+21 FOR
SET DFN=$ORDER(^TMP($JOB,AGNM,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+22 DO PRINT
+23 IF $Y>AGBM
Begin DoDot:3
+24 DO RTRN^AG
+25 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
SET AGSTOP=1
GOTO END1
+26 DO HDR
End DoDot:3
End DoDot:2
IF AGSTOP
QUIT
End DoDot:1
IF AGSTOP
QUIT
+27 IF 'AGSTOP
DO END
+28 QUIT
END WRITE !!!,"TOTAL MEDICARE A & B PATIENTS: ",AGTOT
KILL AG("HAT")
DO RTRN^AG
WRITE $$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 file.
+1 ;DO THEY HAVE BOTH?
+2 IF '$DATA(^AUPNMCR(DFN))!('$$MCDDATES(DFN))
QUIT
+3 WRITE "(REG) ",AGNM,?36,$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+4 SET Y=$$GET1^DIQ(2,DFN_",",.03,"I")
XECUTE ^DD("DD")
WRITE ?64,Y
+5 WRITE !,"(MCR) "
WRITE $$GET1^DIQ(9000003,DFN_",",2101)
+6 ;W ?49,$$GET1^DIQ(9000003,DFN_",",.03),$$GET1^DIQ(9000003,DFN_",",.04) ;IHS/OIT/NKD AG*7.1*14
+7 WRITE ?49,$$GETMCR^AGUTL(DFN)
+8 WRITE ?64,$$GET1^DIQ(9000003,DFN_",",2102)
+9 SET REC=0
+10 FOR
SET REC=$ORDER(^AUPNMCR(DFN,11,REC))
IF 'REC
QUIT
Begin DoDot:1
+11 WRITE !,"(MCR) "
WRITE ?14,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.01)
+12 WRITE ?37,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.03)
+13 WRITE ?49,$$GET1^DIQ(9000003.11,REC_","_DFN_",",.02)
End DoDot:1
+14 ;PRINT MCD INFO
+15 SET REC=""
+16 FOR
SET REC=$ORDER(^AUPNMCD("B",DFN,REC))
IF 'REC
QUIT
Begin DoDot:1
+17 SET AGMCDNM=$$GET1^DIQ(9000004,REC_",",2101)
+18 SET AGMCDDOB=$$GET1^DIQ(9000004,REC_",",2102)
+19 SET AGMCDNUM=$$GET1^DIQ(9000004,REC_",",.03)
+20 WRITE !!,"(MCD) ",AGMCDNM,?49,AGMCDNUM,?64,AGMCDDOB
+21 SET ELIGDT=0
+22 FOR
SET ELIGDT=$ORDER(^AUPNMCD(REC,11,ELIGDT))
IF 'ELIGDT
QUIT
Begin DoDot:2
+23 WRITE !,"(MCD) "
+24 WRITE ?14,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.01)
+25 WRITE ?37,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.03)
+26 WRITE ?49,$$GET1^DIQ(9000004.11,ELIGDT_","_REC_",",.02)
End DoDot:2
End DoDot:1
+27 WRITE !,AG("-"),!
+28 QUIT
+29 ;
MCDDATES(DFN) ;EP - CHECK FOR ANY MCD DATES
+1 NEW REC,EDT,MCDFLAG
+2 SET MCDFLAG=0
+3 SET REC=""
+4 FOR
SET REC=$ORDER(^AUPNMCD("B",DFN,REC))
IF 'REC
QUIT
Begin DoDot:1
+5 SET EDT=0
+6 ;NO DATE ENTRIES
IF '$ORDER(^AUPNMCD(REC,11,EDT))
QUIT
+7 SET MCDFLAG=1
End DoDot:1
+8 QUIT MCDFLAG
+9 ;
HDR SET AGPGPG=AGPGPG+1
+1 WRITE $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG
+2 WRITE !?17,"REGISTERED PATIENTS - MEDICARE/MEDICAID 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 !," NAME",?36,"CHART #",?49,"POL. NUMBER",!,"(TYPE)"
+6 WRITE ?14,"ELIG DATE",?34,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"
+7 WRITE !,AG("="),!
+8 QUIT
