AGDATA ;IHS/SD/EFG - Patient Registration 7.1 BAD DATA FIXER;
;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
;
;PATPTR IS AN ARRAY OF PATIENTS THAT NEED TO BE FIXED
QUEFIX ;EP - QUEUE DATA FIX TO TASKMAN
S ZTRTN="FIXALL^AGDATA(PATPTRS,NOMSG)",ZTDESC="Clean up all known data problems in eligibility records"
S ZTIO=""
S PATPTRS="",NOMSG=1
S ZTSAVE("PATPTRS")=""
S ZTSAVE("NOMSG")=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!,"Cleanup canceled!"
E W !!?5,"Full patient audit queued as Task # ",ZTSK,"!"
H 2
D HOME^%ZIS
Q
FIXALL(PATPTRS,NOMSG) ;EP - FIX ALL ELIGIBLITY KNOWN BAD DATA ISSUES
;Q:'$D(PATPTRS)
;AG*7.1*2
I '$D(PATPTRS) D Q
.D PRVT()
.D RRE()
.D MCD()
.D MCR()
.D GUAR()
.D INSURER
.D POLHCREF()
.D KILL
.I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Data fix is complete."),TS
D PRVT(.PATPTRS)
D RRE(.PATPTRS)
D MCD(.PATPTRS)
D MCR(.PATPTRS)
D GUAR(.PATPTRS)
D POLHCREF(.PATPTRS)
;I '$D(PATPTRS) D INSURER
;I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Data fix is complete."),TS
D KILL
Q
TS D MES^XPDUTL($$HTE^XLFDT($H))
Q
GUAR(PATPTRS) ;EP - CLEAR ANY GUARANTOR ENTRIES WITH NO GUARANTORS ORDATES
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Fixing Guarantor entries with no guarantors or dates."),TS
I $D(PATPTRS) D Q
.S PTR=""
.F S PTR=$O(PATPTRS(PTR)) Q:PTR="" D:$D(^AUPNGUAR(PTR)) GUAR1(PTR)
;IF NO ARRAY PASSED DO THEM ALL
S PATPTR=0
F S PATPTR=$O(^AUPNGUAR(PATPTR)) Q:'PATPTR D GUAR1(PATPTR)
Q
GUAR1(PATPTR) ;EP - DELETE GUARANTOR ENTRIES WITH MISSING GUARANTORS OR DATES
N SUB1,SUB11,REDO
REDO ;
S SUB1=$O(^AUPNGUAR(PATPTR,1,0))
I 'SUB1 D Q ;NO GUARANTORS FOUND AT ALL
.K DIE,DIK,DA,DIC S DIK="^AUPNGUAR(",DA=PATPTR D ^DIK
;FOR EACH GUARANTOR ARE THERE EFFECTIVE DATES
S (SUB1,REDO)=0
F S SUB1=$O(^AUPNGUAR(PATPTR,1,SUB1)) Q:'SUB1 D G REDO:REDO
.S SUB11=$O(^AUPNGUAR(PATPTR,1,SUB1,11,0))
.I 'SUB11 D Q
..S REDO=1 K DIE,DIK,DA,DIC S DA(1)=PATPTR,DA=SUB1,DIK="^AUPNGUAR("_DA(1)_",1," D ^DIK
Q
PRVT(PATPTRS) ;EP - CLEAR ANY PRIVATE ELIG RECORDS MISSING INSURER POINTER
;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Fixing private eligibility with missing .01 field."),TS
I $D(PATPTRS) D Q
.S PTR=""
.F S PTR=$O(PATPTRS(PTR)) Q:PTR="" D:$D(^AUPNPRVT(PTR)) PRVT1(PTR)
;IF NO ARRAY PASSED DO THEM ALL
S PATPTR=0
F S PATPTR=$O(^AUPNPRVT(PATPTR)) Q:'PATPTR D PRVT1(PATPTR)
S PATPTR=0
F S PATPTR=$O(^AUPNPRVT("B",PATPTR)) Q:PATPTR="" D PRVT1(PATPTR)
;AG*7.1*2 IM21986 DANGLING C X-REF. ONLY DONE IF PATPTR NOT DEFINED
;THIS DOES THEM ALL. INDIVIDUAL PATIENT ENTRIES ARE DONE IN ^AGEDPRV
Q:'$D(PATPTRS)
S POLHPTR=0
F S POLHPTR=$O(^AUPNPRVT("C",POLHPTR)) Q:POLHPTR="" D
.S PATPTR=""
.F S PATPTR=$O(^AUPNPRVT("C",POLHPTR,PATPTR)) Q:PATPTR="" D
..S RECNO=""
..F S RECNO=$O(^AUPNPRVT("C",POLHPTR,PATPTR,RECNO)) Q:RECNO="" D
...I '$D(^AUPNPRVT(PATPTR,11,RECNO,0)) K ^AUPNPRVT("C",POLHPTR,PATPTR,RECNO)
Q
PRVT1(PATPTR) ;EP - DELETE PRVT ENTRIES MISSING .01 FIELD
I $P($G(^AUPNPRVT(PATPTR,0)),U)="" K ^AUPNPRVT(PATPTR),^AUPNPRVT("B",PATPTR)
S INSREC=0
F S INSREC=$O(^AUPNPRVT(PATPTR,11,INSREC)) Q:'INSREC D
.I $P($G(^AUPNPRVT(PATPTR,11,INSREC,0)),U)="" K ^AUPNPRVT(PATPTR,11,INSREC) Q
.;I $P($G(^AUPNPRVT(PATPTR,11,INSREC,0)),U,8)="" K DIC,DIK,DIE,DA,DR S DA=INSREC,DA(1)=PATPTR,DIK="^AUPNPRVT("_DA(1)_",11," D ^DIK K DIC,DIK,DIE,DA,DR Q ;ALLOW ADDING OF POLICY HOLDER
.I $O(^AUPNPRVT(PATPTR,11,0)) Q
.K DIC,DIK,DIE,DA,DR S DA=PATPTR,DIK="^AUPNPRVT(" D ^DIK K DIC,DIK,DIE,DA,DR
Q
MCD(PATPTRS) ;EP - DELETE MCD RECORDS MISSING .01 FIELD
N HRN,DFN,ST,MCDNUM,PTR,RECNO
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Optimizing Medicaid eligibility entries."),TS
;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
I $D(PATPTRS) D Q
.S PTR=""
.F S PTR=$O(PATPTRS(PTR)) Q:PTR="" D Q
..S RECNO=$O(^AUPNMCD("B",PTR,""))
..Q:RECNO=""
..D MCD1(RECNO)
..D MCD2(RECNO)
;IF NO ARRAY PASSED DO ALL ENTRIES
S RECNO=0
F S RECNO=$O(^AUPNMCD(RECNO)) Q:'RECNO D MCD1(RECNO)
S PATPTR=0
F S PATPTR=$O(^AUPNMCD("AB",PATPTR)) Q:'PATPTR D MCD2(PATPTR)
Q
MCD1(RECNO) ;EP
I $P($G(^AUPNMCD(RECNO,0)),U)="" K ^AUPNMCD(RECNO) Q ;GET RID OF WHOLE THING INCLUDING SUBFILE
;IF THE INS. PTR IS MISSING LETS FIX IT SO TPB CLAIMS GENERATOR DOESN'T BLOW UP
I $P($G(^AUPNMCD(RECNO,0)),U,2)="" D
.K DIC,DIK,DIE,DA,DR
.S MCDPTR=$O(^AUTNINS("B","MEDICAID",""))
.S DA=RECNO,DIE="^AUPNMCD(",DR=".02///^S X=MCDPTR"
.D ^DIE
.K DIC,DIK,DIE,DA,DR
S ELIGREC=0
F S ELIGREC=$O(^AUPNMCD(RECNO,11,ELIGREC)) Q:'ELIGREC D
.I $P($G(^AUPNMCD(RECNO,11,ELIGREC,0)),U)="" K ^AUPNMCD(RECNO,11,ELIGREC)
Q
;
MCD2(PTR) ;EP
S ST="" F S ST=$O(^AUPNMCD("AB",PTR,ST)) Q:ST="" D
.S MCDNUM="" F S MCDNUM=$O(^AUPNMCD("AB",PTR,ST,MCDNUM)) Q:MCDNUM="" D
..S RECNO="" F S RECNO=$O(^AUPNMCD("AB",PTR,ST,MCDNUM,RECNO)) Q:RECNO="" D
...I $P($G(^AUPNMCD(RECNO,0)),U)="" K ^AUPNMCD(RECNO),^AUPNMCD("AB",PTR,ST,MCDNUM,RECNO)
Q
RRE(PATPTRS) ;FIX "B" X-REF ENTRIES WITH NO ZERO RECORD
;MUST DO DIRECT KILL BECAUSE RECORD NOT THERE. BOMBS ON USE OF ^DIK DOESN'T WORK
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Optimizing Railroad eligibility entries."),TS
I $D(PATPTRS) D Q
.S PATPTR=0
.F S PATPTR=$O(PATPTRS(PATPTR)) Q:'PTR D:$D(^AUPNRRE(PATPTR)) RRE1(PATPTR)
;IF NO ARRAY PASSED DO THEM ALL
S PATPTR=""
F S PATPTR=$O(^AUPNRRE("B",PATPTR)) Q:'PATPTR D RRE1(PATPTR)
S PATPTR=0
F S PATPTR=$O(^AUPNRRE(PATPTR)) Q:'PATPTR D RRE1(PATPTR)
Q
RRE1(PATPTR) ;EP
I $P($G(^AUPNRRE(PATPTR,0)),U)="" K ^AUPNRRE(PATPTR),^AUPNRRE("B",PATPTR)
Q
MCR(PATPTRS) ;EP - FIX MEDICARE WITH MISSING .01 FIELDS
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Optimizing Medicare eligibility entries."),TS
I $D(PATPTRS) D Q
.S PTR="" F S PTR=$O(PATPTRS(PTR)) Q:'PTR D:$D(^AUPNMCR(PATPTR)) MCR1(PTR),MCR2(PTR)
;IF NO ARRAY PASSED DO THEM ALL
S PATPTR=0
F S PATPTR=$O(^AUPNMCR(PATPTR)) Q:'PATPTR D MCR1(PATPTR),MCR2(PATPTR)
S PATPTR=0
F S PATPTR=$O(^AUPNMCR("B",PATPTR)) Q:'PATPTR D MCR1(PATPTR)
Q
MCR1(PATPTR) ;EP
I $P($G(^AUPNMCR(PATPTR,0)),U)="" K ^AUPNMCR(PATPTR),^AUPNMCR("B",PATPTR)
Q
MCR2(PATPTR) ;EP
I $P($G(^AUPNMCR(PATPTR,0)),U)="" Q
I '$O(^AUPNMCR(PATPTR,11,0)) D Q
.K DIR,DIE,DIC,DA
.S DA=PATPTR
.S DIK="^AUPNMCR("
.D ^DIK
.K DIR,DIE,DIC,DA
Q
INSURER ;EP - DELETE DECIMAL IENS FROM INSURER FILE
I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Deleting Insurer records with decimal in IEN"),TS
S INSPTR=0
F S INSPTR=$O(^AUTNINS(INSPTR)) Q:'INSPTR D
.I INSPTR[(".") K ^AUTNINS(INSPTR),^AUTNINS("B",INSPTR)
Q
KILL ;EP - KILL VARS
K PATPTR,INSPTR,PTR,RECNO,ELIGREC,INSREC
Q
;POLM=ARRAY OF PAT. DFN
POLHCREF(POLM,INFOONLY) ;EP
;FOR FIXING DOUBLE POLICY HOLDER "C" X-REFS
;THIS IS A LOUSY FIX,VERY INEFFICIENT
I '$D(ZTQUEUED),('$G(NOMSG)) D BMES^XPDUTL("Fixing double ""C"" x-refs entries pointing to the wrong records"),TS
S:$G(INFOONLY)="" INFOONLY=0 ;MUST SEND INFOONLY AS 1 TO JUST SEE BAD X-REFS
Q:$D(POLM)'=10
S POLM=$O(POLM(""))
Q:POLM=""
S POLH=""
F S POLH=$O(^AUPNPRVT("C",POLH)) Q:POLH="" D
.Q:'$D(^AUPNPRVT("C",POLH,POLM))
.D POLHCRE1(POLH,POLM,INFOONLY)
Q
;POLH = POLICY HOLDER PTR
;POLM = ARRAY OF PT DFN
POLHCRE1(POLH,POLM,INFOONLY) ;EP
W:INFOONLY !,"POLH: ",POLH,?15,"POLM: ",POLM
;W !,"POLH: ",POLH,?15,"POLM: ",POLM
S REC=""
F S REC=$O(^AUPNPRVT("C",POLH,POLM,REC)) Q:REC="" D
.S TRUEPOLH=$P($G(^AUPNPRVT(POLM,11,REC,0)),U,8)
.Q:TRUEPOLH=POLH
.I INFOONLY D Q
..W !?5,"BAD X-REF"
..W !?10,POLH,"***",POLM,"***",REC
..W !?15,TRUEPOLH
..W !
.K ^AUPNPRVT("C",POLH,POLM,REC)
Q
AGDATA ;IHS/SD/EFG - Patient Registration 7.1 BAD DATA FIXER;
+1 ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
+2 ;
+3 ;PATPTR IS AN ARRAY OF PATIENTS THAT NEED TO BE FIXED
QUEFIX ;EP - QUEUE DATA FIX TO TASKMAN
+1 SET ZTRTN="FIXALL^AGDATA(PATPTRS,NOMSG)"
SET ZTDESC="Clean up all known data problems in eligibility records"
+2 SET ZTIO=""
+3 SET PATPTRS=""
SET NOMSG=1
+4 SET ZTSAVE("PATPTRS")=""
+5 SET ZTSAVE("NOMSG")=""
+6 DO ^%ZTLOAD
+7 IF $DATA(ZTSK)[0
WRITE !!,"Cleanup canceled!"
+8 IF '$TEST
WRITE !!?5,"Full patient audit queued as Task # ",ZTSK,"!"
+9 HANG 2
+10 DO HOME^%ZIS
+11 QUIT
FIXALL(PATPTRS,NOMSG) ;EP - FIX ALL ELIGIBLITY KNOWN BAD DATA ISSUES
+1 ;Q:'$D(PATPTRS)
+2 ;AG*7.1*2
+3 IF '$DATA(PATPTRS)
Begin DoDot:1
+4 DO PRVT()
+5 DO RRE()
+6 DO MCD()
+7 DO MCR()
+8 DO GUAR()
+9 DO INSURER
+10 DO POLHCREF()
+11 DO KILL
+12 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Data fix is complete.")
DO TS
End DoDot:1
QUIT
+13 DO PRVT(.PATPTRS)
+14 DO RRE(.PATPTRS)
+15 DO MCD(.PATPTRS)
+16 DO MCR(.PATPTRS)
+17 DO GUAR(.PATPTRS)
+18 DO POLHCREF(.PATPTRS)
+19 ;I '$D(PATPTRS) D INSURER
+20 ;I '$D(ZTQUEUED),('NOMSG) D BMES^XPDUTL("Data fix is complete."),TS
+21 DO KILL
+22 QUIT
TS DO MES^XPDUTL($$HTE^XLFDT($HOROLOG))
+1 QUIT
GUAR(PATPTRS) ;EP - CLEAR ANY GUARANTOR ENTRIES WITH NO GUARANTORS ORDATES
+1 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Fixing Guarantor entries with no guarantors or dates.")
DO TS
+2 IF $DATA(PATPTRS)
Begin DoDot:1
+3 SET PTR=""
+4 FOR
SET PTR=$ORDER(PATPTRS(PTR))
IF PTR=""
QUIT
IF $DATA(^AUPNGUAR(PTR))
DO GUAR1(PTR)
End DoDot:1
QUIT
+5 ;IF NO ARRAY PASSED DO THEM ALL
+6 SET PATPTR=0
+7 FOR
SET PATPTR=$ORDER(^AUPNGUAR(PATPTR))
IF 'PATPTR
QUIT
DO GUAR1(PATPTR)
+8 QUIT
GUAR1(PATPTR) ;EP - DELETE GUARANTOR ENTRIES WITH MISSING GUARANTORS OR DATES
+1 NEW SUB1,SUB11,REDO
REDO ;
+1 SET SUB1=$ORDER(^AUPNGUAR(PATPTR,1,0))
+2 ;NO GUARANTORS FOUND AT ALL
IF 'SUB1
Begin DoDot:1
+3 KILL DIE,DIK,DA,DIC
SET DIK="^AUPNGUAR("
SET DA=PATPTR
DO ^DIK
End DoDot:1
QUIT
+4 ;FOR EACH GUARANTOR ARE THERE EFFECTIVE DATES
+5 SET (SUB1,REDO)=0
+6 FOR
SET SUB1=$ORDER(^AUPNGUAR(PATPTR,1,SUB1))
IF 'SUB1
QUIT
Begin DoDot:1
+7 SET SUB11=$ORDER(^AUPNGUAR(PATPTR,1,SUB1,11,0))
+8 IF 'SUB11
Begin DoDot:2
+9 SET REDO=1
KILL DIE,DIK,DA,DIC
SET DA(1)=PATPTR
SET DA=SUB1
SET DIK="^AUPNGUAR("_DA(1)_",1,"
DO ^DIK
End DoDot:2
QUIT
End DoDot:1
IF REDO
GOTO REDO
+10 QUIT
PRVT(PATPTRS) ;EP - CLEAR ANY PRIVATE ELIG RECORDS MISSING INSURER POINTER
+1 ;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
+2 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Fixing private eligibility with missing .01 field.")
DO TS
+3 IF $DATA(PATPTRS)
Begin DoDot:1
+4 SET PTR=""
+5 FOR
SET PTR=$ORDER(PATPTRS(PTR))
IF PTR=""
QUIT
IF $DATA(^AUPNPRVT(PTR))
DO PRVT1(PTR)
End DoDot:1
QUIT
+6 ;IF NO ARRAY PASSED DO THEM ALL
+7 SET PATPTR=0
+8 FOR
SET PATPTR=$ORDER(^AUPNPRVT(PATPTR))
IF 'PATPTR
QUIT
DO PRVT1(PATPTR)
+9 SET PATPTR=0
+10 FOR
SET PATPTR=$ORDER(^AUPNPRVT("B",PATPTR))
IF PATPTR=""
QUIT
DO PRVT1(PATPTR)
+11 ;AG*7.1*2 IM21986 DANGLING C X-REF. ONLY DONE IF PATPTR NOT DEFINED
+12 ;THIS DOES THEM ALL. INDIVIDUAL PATIENT ENTRIES ARE DONE IN ^AGEDPRV
+13 IF '$DATA(PATPTRS)
QUIT
+14 SET POLHPTR=0
+15 FOR
SET POLHPTR=$ORDER(^AUPNPRVT("C",POLHPTR))
IF POLHPTR=""
QUIT
Begin DoDot:1
+16 SET PATPTR=""
+17 FOR
SET PATPTR=$ORDER(^AUPNPRVT("C",POLHPTR,PATPTR))
IF PATPTR=""
QUIT
Begin DoDot:2
+18 SET RECNO=""
+19 FOR
SET RECNO=$ORDER(^AUPNPRVT("C",POLHPTR,PATPTR,RECNO))
IF RECNO=""
QUIT
Begin DoDot:3
+20 IF '$DATA(^AUPNPRVT(PATPTR,11,RECNO,0))
KILL ^AUPNPRVT("C",POLHPTR,PATPTR,RECNO)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
PRVT1(PATPTR) ;EP - DELETE PRVT ENTRIES MISSING .01 FIELD
+1 IF $PIECE($GET(^AUPNPRVT(PATPTR,0)),U)=""
KILL ^AUPNPRVT(PATPTR),^AUPNPRVT("B",PATPTR)
+2 SET INSREC=0
+3 FOR
SET INSREC=$ORDER(^AUPNPRVT(PATPTR,11,INSREC))
IF 'INSREC
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNPRVT(PATPTR,11,INSREC,0)),U)=""
KILL ^AUPNPRVT(PATPTR,11,INSREC)
QUIT
+5 ;I $P($G(^AUPNPRVT(PATPTR,11,INSREC,0)),U,8)="" K DIC,DIK,DIE,DA,DR S DA=INSREC,DA(1)=PATPTR,DIK="^AUPNPRVT("_DA(1)_",11," D ^DIK K DIC,DIK,DIE,DA,DR Q ;ALLOW ADDING OF POLICY HOLDER
+6 IF $ORDER(^AUPNPRVT(PATPTR,11,0))
QUIT
+7 KILL DIC,DIK,DIE,DA,DR
SET DA=PATPTR
SET DIK="^AUPNPRVT("
DO ^DIK
KILL DIC,DIK,DIE,DA,DR
End DoDot:1
+8 QUIT
MCD(PATPTRS) ;EP - DELETE MCD RECORDS MISSING .01 FIELD
+1 NEW HRN,DFN,ST,MCDNUM,PTR,RECNO
+2 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Optimizing Medicaid eligibility entries.")
DO TS
+3 ;MUST DO DIRECT KILL BECAUSE X-REF NOT THERE. BOMBS ON USE OF ^DIK
+4 IF $DATA(PATPTRS)
Begin DoDot:1
+5 SET PTR=""
+6 FOR
SET PTR=$ORDER(PATPTRS(PTR))
IF PTR=""
QUIT
Begin DoDot:2
+7 SET RECNO=$ORDER(^AUPNMCD("B",PTR,""))
+8 IF RECNO=""
QUIT
+9 DO MCD1(RECNO)
+10 DO MCD2(RECNO)
End DoDot:2
QUIT
End DoDot:1
QUIT
+11 ;IF NO ARRAY PASSED DO ALL ENTRIES
+12 SET RECNO=0
+13 FOR
SET RECNO=$ORDER(^AUPNMCD(RECNO))
IF 'RECNO
QUIT
DO MCD1(RECNO)
+14 SET PATPTR=0
+15 FOR
SET PATPTR=$ORDER(^AUPNMCD("AB",PATPTR))
IF 'PATPTR
QUIT
DO MCD2(PATPTR)
+16 QUIT
MCD1(RECNO) ;EP
+1 ;GET RID OF WHOLE THING INCLUDING SUBFILE
IF $PIECE($GET(^AUPNMCD(RECNO,0)),U)=""
KILL ^AUPNMCD(RECNO)
QUIT
+2 ;IF THE INS. PTR IS MISSING LETS FIX IT SO TPB CLAIMS GENERATOR DOESN'T BLOW UP
+3 IF $PIECE($GET(^AUPNMCD(RECNO,0)),U,2)=""
Begin DoDot:1
+4 KILL DIC,DIK,DIE,DA,DR
+5 SET MCDPTR=$ORDER(^AUTNINS("B","MEDICAID",""))
+6 SET DA=RECNO
SET DIE="^AUPNMCD("
SET DR=".02///^S X=MCDPTR"
+7 DO ^DIE
+8 KILL DIC,DIK,DIE,DA,DR
End DoDot:1
+9 SET ELIGREC=0
+10 FOR
SET ELIGREC=$ORDER(^AUPNMCD(RECNO,11,ELIGREC))
IF 'ELIGREC
QUIT
Begin DoDot:1
+11 IF $PIECE($GET(^AUPNMCD(RECNO,11,ELIGREC,0)),U)=""
KILL ^AUPNMCD(RECNO,11,ELIGREC)
End DoDot:1
+12 QUIT
+13 ;
MCD2(PTR) ;EP
+1 SET ST=""
FOR
SET ST=$ORDER(^AUPNMCD("AB",PTR,ST))
IF ST=""
QUIT
Begin DoDot:1
+2 SET MCDNUM=""
FOR
SET MCDNUM=$ORDER(^AUPNMCD("AB",PTR,ST,MCDNUM))
IF MCDNUM=""
QUIT
Begin DoDot:2
+3 SET RECNO=""
FOR
SET RECNO=$ORDER(^AUPNMCD("AB",PTR,ST,MCDNUM,RECNO))
IF RECNO=""
QUIT
Begin DoDot:3
+4 IF $PIECE($GET(^AUPNMCD(RECNO,0)),U)=""
KILL ^AUPNMCD(RECNO),^AUPNMCD("AB",PTR,ST,MCDNUM,RECNO)
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
RRE(PATPTRS) ;FIX "B" X-REF ENTRIES WITH NO ZERO RECORD
+1 ;MUST DO DIRECT KILL BECAUSE RECORD NOT THERE. BOMBS ON USE OF ^DIK DOESN'T WORK
+2 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Optimizing Railroad eligibility entries.")
DO TS
+3 IF $DATA(PATPTRS)
Begin DoDot:1
+4 SET PATPTR=0
+5 FOR
SET PATPTR=$ORDER(PATPTRS(PATPTR))
IF 'PTR
QUIT
IF $DATA(^AUPNRRE(PATPTR))
DO RRE1(PATPTR)
End DoDot:1
QUIT
+6 ;IF NO ARRAY PASSED DO THEM ALL
+7 SET PATPTR=""
+8 FOR
SET PATPTR=$ORDER(^AUPNRRE("B",PATPTR))
IF 'PATPTR
QUIT
DO RRE1(PATPTR)
+9 SET PATPTR=0
+10 FOR
SET PATPTR=$ORDER(^AUPNRRE(PATPTR))
IF 'PATPTR
QUIT
DO RRE1(PATPTR)
+11 QUIT
RRE1(PATPTR) ;EP
+1 IF $PIECE($GET(^AUPNRRE(PATPTR,0)),U)=""
KILL ^AUPNRRE(PATPTR),^AUPNRRE("B",PATPTR)
+2 QUIT
MCR(PATPTRS) ;EP - FIX MEDICARE WITH MISSING .01 FIELDS
+1 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Optimizing Medicare eligibility entries.")
DO TS
+2 IF $DATA(PATPTRS)
Begin DoDot:1
+3 SET PTR=""
FOR
SET PTR=$ORDER(PATPTRS(PTR))
IF 'PTR
QUIT
IF $DATA(^AUPNMCR(PATPTR))
DO MCR1(PTR)
DO MCR2(PTR)
End DoDot:1
QUIT
+4 ;IF NO ARRAY PASSED DO THEM ALL
+5 SET PATPTR=0
+6 FOR
SET PATPTR=$ORDER(^AUPNMCR(PATPTR))
IF 'PATPTR
QUIT
DO MCR1(PATPTR)
DO MCR2(PATPTR)
+7 SET PATPTR=0
+8 FOR
SET PATPTR=$ORDER(^AUPNMCR("B",PATPTR))
IF 'PATPTR
QUIT
DO MCR1(PATPTR)
+9 QUIT
MCR1(PATPTR) ;EP
+1 IF $PIECE($GET(^AUPNMCR(PATPTR,0)),U)=""
KILL ^AUPNMCR(PATPTR),^AUPNMCR("B",PATPTR)
+2 QUIT
MCR2(PATPTR) ;EP
+1 IF $PIECE($GET(^AUPNMCR(PATPTR,0)),U)=""
QUIT
+2 IF '$ORDER(^AUPNMCR(PATPTR,11,0))
Begin DoDot:1
+3 KILL DIR,DIE,DIC,DA
+4 SET DA=PATPTR
+5 SET DIK="^AUPNMCR("
+6 DO ^DIK
+7 KILL DIR,DIE,DIC,DA
End DoDot:1
QUIT
+8 QUIT
INSURER ;EP - DELETE DECIMAL IENS FROM INSURER FILE
+1 IF '$DATA(ZTQUEUED)
IF ('NOMSG)
DO BMES^XPDUTL("Deleting Insurer records with decimal in IEN")
DO TS
+2 SET INSPTR=0
+3 FOR
SET INSPTR=$ORDER(^AUTNINS(INSPTR))
IF 'INSPTR
QUIT
Begin DoDot:1
+4 IF INSPTR[(".")
KILL ^AUTNINS(INSPTR),^AUTNINS("B",INSPTR)
End DoDot:1
+5 QUIT
KILL ;EP - KILL VARS
+1 KILL PATPTR,INSPTR,PTR,RECNO,ELIGREC,INSREC
+2 QUIT
+3 ;POLM=ARRAY OF PAT. DFN
POLHCREF(POLM,INFOONLY) ;EP
+1 ;FOR FIXING DOUBLE POLICY HOLDER "C" X-REFS
+2 ;THIS IS A LOUSY FIX,VERY INEFFICIENT
+3 IF '$DATA(ZTQUEUED)
IF ('$GET(NOMSG))
DO BMES^XPDUTL("Fixing double ""C"" x-refs entries pointing to the wrong records")
DO TS
+4 ;MUST SEND INFOONLY AS 1 TO JUST SEE BAD X-REFS
IF $GET(INFOONLY)=""
SET INFOONLY=0
+5 IF $DATA(POLM)'=10
QUIT
+6 SET POLM=$ORDER(POLM(""))
+7 IF POLM=""
QUIT
+8 SET POLH=""
+9 FOR
SET POLH=$ORDER(^AUPNPRVT("C",POLH))
IF POLH=""
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNPRVT("C",POLH,POLM))
QUIT
+11 DO POLHCRE1(POLH,POLM,INFOONLY)
End DoDot:1
+12 QUIT
+13 ;POLH = POLICY HOLDER PTR
+14 ;POLM = ARRAY OF PT DFN
POLHCRE1(POLH,POLM,INFOONLY) ;EP
+1 IF INFOONLY
WRITE !,"POLH: ",POLH,?15,"POLM: ",POLM
+2 ;W !,"POLH: ",POLH,?15,"POLM: ",POLM
+3 SET REC=""
+4 FOR
SET REC=$ORDER(^AUPNPRVT("C",POLH,POLM,REC))
IF REC=""
QUIT
Begin DoDot:1
+5 SET TRUEPOLH=$PIECE($GET(^AUPNPRVT(POLM,11,REC,0)),U,8)
+6 IF TRUEPOLH=POLH
QUIT
+7 IF INFOONLY
Begin DoDot:2
+8 WRITE !?5,"BAD X-REF"
+9 WRITE !?10,POLH,"***",POLM,"***",REC
+10 WRITE !?15,TRUEPOLH
+11 WRITE !
End DoDot:2
QUIT
+12 KILL ^AUPNPRVT("C",POLH,POLM,REC)
End DoDot:1
+13 QUIT
