- AGMCRP5 ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE A&B 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^AGMCRP5",ZTUCI=Y,ZTIO="",ZTDESC="Alpha List MEDICARE A & B 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.
- ;this is to make sure they are Part A and B somewhere
- S (I,AGCFLAGA,AGCFLAGB)="" ;SET A FLAG AND B FLAG
- F S I=$O(^AUPNMCR(DFN,11,I)) Q:I="" D
- .S AGCOV=""
- .S AGCOV=$P($G(^AUPNMCR(DFN,11,I,0)),U,3)
- .I AGCOV="A" S AGCFLAGA=1
- .I AGCOV="B" S AGCFLAGB=1
- Q:AGCFLAGA'=1!(AGCFLAGB'=1)
- W "(REG) ",AGNM,?36,$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
- W ?64,$$GET1^DIQ(2,DFN_",",.03)
- S DIC=9000003,DR=2101,DA=DFN D ^AGDICLK K AGMCRNM I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AGMCRNM=AG("LKPRINT")
- S DR=2102 D ^AGDICLK K AGMCRDB I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AGMCRDB=AG("LKPRINT")
- ;W !,"(MCR) " W AGMCRNM,?49,$$GET1^DIQ(9000003,DFN_",",.03)_$$GET1^DIQ(9000003,DFN_",",.04) W ?64,AGMCRDB K AGMCRNM,AGMCRDB ;IHS/OIT/NKD AG*7.1*14
- W !,"(MCR) " W AGMCRNM,?49,$$GETMCR^AGUTL(DFN) W ?64,AGMCRDB K AGMCRNM,AGMCRDB
- S DIC=9000003.11,DA=DFN
- S I=""
- F S I=$O(^AUPNMCR(DFN,11,I)) Q:I="" D
- .S AGCOV=$P($G(^AUPNMCR(DFN,11,I,0)),U,3)
- .Q:AGCOV="D"
- .S DR=.01,AG("DRENT1")=I D ^AGDICLK
- .W !,"(MCR) " W:$D(AG("LKPRINT")) ?14,AG("LKPRINT")
- .S DR=.03,AG("DRENT1")=I D ^AGDICLK W:$D(AG("LKPRINT")) ?37,AG("LKPRINT")
- .S DR=.02,AG("DRENT1")=I D ^AGDICLK W:$D(AG("LKPRINT")) ?49,AG("LKPRINT")
- W !,AG("-"),!
- Q
- HDR S AGPGPG=AGPGPG+1
- W $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG
- W !?17,"REGISTERED PATIENTS - MEDICARE A & B 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,"NUMBER",!,"(TYPE)",?14,"ELIG DATE",?34,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"
- W !,AG("="),!
- Q
- AGMCRP5 ; IHS/ASDS/EFG - PRINT ALPHA LIST OF MEDICARE A&B 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^AGMCRP5"
- SET ZTUCI=Y
- SET ZTIO=""
- SET ZTDESC="Alpha List MEDICARE A & B 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 ;this is to make sure they are Part A and B somewhere
- +2 ;SET A FLAG AND B FLAG
- SET (I,AGCFLAGA,AGCFLAGB)=""
- +3 FOR
- SET I=$ORDER(^AUPNMCR(DFN,11,I))
- IF I=""
- QUIT
- Begin DoDot:1
- +4 SET AGCOV=""
- +5 SET AGCOV=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)
- +6 IF AGCOV="A"
- SET AGCFLAGA=1
- +7 IF AGCOV="B"
- SET AGCFLAGB=1
- End DoDot:1
- +8 IF AGCFLAGA'=1!(AGCFLAGB'=1)
- QUIT
- +9 WRITE "(REG) ",AGNM,?36,$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
- +10 WRITE ?64,$$GET1^DIQ(2,DFN_",",.03)
- +11 SET DIC=9000003
- SET DR=2101
- SET DA=DFN
- DO ^AGDICLK
- KILL AGMCRNM
- IF $DATA(AG("LKPRINT"))
- IF AG("LKPRINT")]""
- SET AGMCRNM=AG("LKPRINT")
- +12 SET DR=2102
- DO ^AGDICLK
- KILL AGMCRDB
- IF $DATA(AG("LKPRINT"))
- IF AG("LKPRINT")]""
- SET AGMCRDB=AG("LKPRINT")
- +13 ;W !,"(MCR) " W AGMCRNM,?49,$$GET1^DIQ(9000003,DFN_",",.03)_$$GET1^DIQ(9000003,DFN_",",.04) W ?64,AGMCRDB K AGMCRNM,AGMCRDB ;IHS/OIT/NKD AG*7.1*14
- +14 WRITE !,"(MCR) "
- WRITE AGMCRNM,?49,$$GETMCR^AGUTL(DFN)
- WRITE ?64,AGMCRDB
- KILL AGMCRNM,AGMCRDB
- +15 SET DIC=9000003.11
- SET DA=DFN
- +16 SET I=""
- +17 FOR
- SET I=$ORDER(^AUPNMCR(DFN,11,I))
- IF I=""
- QUIT
- Begin DoDot:1
- +18 SET AGCOV=$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)
- +19 IF AGCOV="D"
- QUIT
- +20 SET DR=.01
- SET AG("DRENT1")=I
- DO ^AGDICLK
- +21 WRITE !,"(MCR) "
- IF $DATA(AG("LKPRINT"))
- WRITE ?14,AG("LKPRINT")
- +22 SET DR=.03
- SET AG("DRENT1")=I
- DO ^AGDICLK
- IF $DATA(AG("LKPRINT"))
- WRITE ?37,AG("LKPRINT")
- +23 SET DR=.02
- SET AG("DRENT1")=I
- DO ^AGDICLK
- IF $DATA(AG("LKPRINT"))
- WRITE ?49,AG("LKPRINT")
- End DoDot:1
- +24 WRITE !,AG("-"),!
- +25 QUIT
- HDR SET AGPGPG=AGPGPG+1
- +1 WRITE $$S^AGVDF("IOF"),!!,AG("USRLOC"),?72,"page ",AGPGPG
- +2 WRITE !?17,"REGISTERED PATIENTS - MEDICARE A & B 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,"NUMBER",!,"(TYPE)",?14,"ELIG DATE",?34,"COVERAGE",?49,"ELIG END DATE",?64,"DATE OF BIRTH"
- +6 WRITE !,AG("="),!
- +7 QUIT
