Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGDATA

AGDATA.m

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