AUPNMCDF.m

AUPNMCDF ;IHS/OIT/NKD - MCD Eligiblity fix ; 02/19/2015

 ;;99.1;IHS DICTIONARIES (PATIENT);**24**;MAR 9, 1999;Build 1

 ; 

 ; VARIABLE NAMING SCHEME:

 ;  SC=SCAN GLOBAL, FX=FIX GLOBAL, EX=EXCLUDE GLOBAL

 ;  P=PATIENT IEN, I=RECORD IEN, I2=SUB-RECORD IEN, O=OLD VALUE, N=NEW VALUE

 ;  A=ANCILLARY, AL=ANCILLARY LIST, RO=ROUTINE, VR=VERSION

 ;  S=SEQUENCE, V=OVERRIDE, F=FLAG, FL=FILE, FLD=FIELD, DT=DATE

 ;  C=COUNT/ITERATOR, D=DATA, T=TEMP, R=RESULT, Q=QUIET

 ;

 N AUPNQ S AUPNQ=1

 D SETANC,SCAN,RPT1,RPT2,RPT3

 Q

 ;

MAIN ; EP - MAIN MENU

 N DIR,DTOUT,DUOUT,DIRUT,DIROUT

 D SETANC

 F  Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)  D

 . W !!,?8,"Medicaid Eligibility Fix"

 . W !,?23,"Scan last run at: ",$S($G(^AUPNTMP("SCAN","DT")):$$FMTE^XLFDT($G(^AUPNTMP("SCAN","DT"))),1:"Never")

 . W !,?10,"(S)can",?25,"Scan and fix corrupt entries"

 . W !,?10,"(V)erify",?25,"Verify results of previous scans"

 . W !,?10,"(R)esults",?25,"Display scan results"

 . S DIR(0)="SAO^S:SCAN;V:VERIFY;R:RESULTS"

 . S DIR("A")="(S)CAN, (V)ERIFY, (R)ESULTS: "

 . D ^DIR

 . Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)

 . I $G(Y)="S" D SCAN,CONT

 . E  I $G(Y)="V" D CHKPREV,CONT

 . E  I $G(Y)="R" D RPT1,CONT,RPT2,CONT,RPT3,CONT

 . K DIR,DTOUT,DUOUT,DIRUT,DIROUT

 Q

 ;

SCAN ; SCAN MCD ELIGIBILITY RECORDS FOR NON-DINUMED SUB-RECORDS

 N AUPNSC,AUPNI,AUPNI2,AUPNDT,AUPNR,AUPNP

 S AUPNSC=$NA(^AUPNTMP("SCAN")) K @AUPNSC

 W !!,"Scanning AUPNMCD global"

 S @AUPNSC@("DT")=$$NOW^XLFDT

 S AUPNI=0 F  S AUPNI=$O(^AUPNMCD(AUPNI)) Q:'AUPNI  D

 . S AUPNP=$P($G(^AUPNMCD(AUPNI,0)),U) Q:'AUPNP

 . D INC($NA(@AUPNSC@("TOT"))) I '($G(@AUPNSC@("TOT"))#5000) W "."

 . S AUPNI2=0 F  S AUPNI2=$O(^AUPNMCD(AUPNI,11,AUPNI2)) Q:'AUPNI2  D

 . . S AUPNDT=$P($G(^AUPNMCD(AUPNI,11,AUPNI2,0)),U) Q:AUPNDT=AUPNI2

 . . I AUPNDT'?7N D INC($NA(@AUPNSC@("ERR"))) Q  ; SKIP IF NOT A DATE

 . . I '$D(@AUPNSC@(AUPNP)) D INC($NA(@AUPNSC@("PAT")))

 . . I '$D(@AUPNSC@(AUPNP,AUPNI)) D INC($NA(@AUPNSC@("REC")))

 . . D INC($NA(@AUPNSC@("SUB")))

 . . S @AUPNSC@(AUPNP,AUPNI)=""

 W "Completed!",?40,"Total records scanned: ",+$G(@AUPNSC@("TOT"))

 I '+$G(@AUPNSC@("REC")) W !,"No issues found to correct!" Q

 W !,?10,"Record count: ",+$G(@AUPNSC@("REC")),?40,"Entry count: ",+$G(@AUPNSC@("SUB"))

 I '$G(@AUPNSC@("OLD")),$$ASK("Proceed with correction","Y") D PRC

 Q

 ;

PRC ; PROCESS RESULTS FROM A SCAN

 N AUPNSC,AUPNFX,AUPNEX,AUPNP,AUPNI,AUPNV

 S AUPNSC=$NA(^AUPNTMP("SCAN"))

 D INC($NA(^AUPNTMP("FIXED",0)))

 S AUPNFX=$NA(^AUPNTMP("FIXED",+$$GETFIX)),AUPNEX=$NA(^AUPNTMP("EXCLUDE")) K @AUPNEX

 S AUPNV=$$ASK("Override coverage overlap checks","Y")

 W !!,"Processing ",$G(@AUPNSC@("SUB"))," entries in the MEDICAID ELIGIBILE file..."

 S @AUPNFX@(0)="0"_U_$$NOW^XLFDT_U_DUZ_U_AUPNV  ; STORE ENTRY COUNT, DATE/TIME, USER, AND OVERRIDE

 S AUPNP=0 F  S AUPNP=$O(@AUPNSC@(AUPNP)) Q:'AUPNP  D

 . S AUPNI=0 F  S AUPNI=$O(@AUPNSC@(AUPNP,AUPNI)) Q:'AUPNI  D

 . . D REC(AUPNP,AUPNI,AUPNFX,AUPNEX,AUPNV)

 W "Completed!"

 I +$G(@AUPNFX@(0)) W !,+$G(@AUPNFX@(0))," entries successfully processed"

 I +$G(@AUPNEX) W !,+$G(@AUPNEX)," entries were excluded - See report for details"

 Q

 ;

REC(AUPNP,AUPNI,AUPNFX,AUPNEX,AUPNV) ; PROCESS A SINGLE RECORD

 N AUPNO,AUPNN,AUPNS,AUPNCHG,AUPNA,AUPNRO

 S AUPNP=$G(AUPNP),AUPNI=$G(AUPNI),AUPNFX=$G(AUPNFX),AUPNEX=$G(AUPNEX),AUPNV=+$G(AUPNV),AUPNCHG=1 Q:'AUPNP  Q:'AUPNI

 F  Q:'AUPNCHG  D  ; LOOP UNTIL NO SUB-RECORDS CHANGED - SEQUENCE/ORDER REQUIRED FOR CORRECTION

 . N AUPNE

 . S (AUPNCHG,AUPNO)=0 F  S AUPNO=$O(^AUPNMCD(AUPNI,11,AUPNO)) Q:'AUPNO  D

 . . S AUPNN=$P($G(^AUPNMCD(AUPNI,11,AUPNO,0)),U) Q:AUPNO=AUPNN!(AUPNN'?7N)

 . . Q:$$CHKONE(AUPNI,AUPNO,"AUPNE",AUPNV)

 . . D INC($NA(@AUPNFX@(0)),,1) S AUPNS=+$G(@AUPNFX@(0))

 . . S @AUPNFX@(AUPNS)=AUPNP_U_AUPNI_U_AUPNO_U_AUPNN  ; LOG SUB-RECORD CHANGED

 . . S @AUPNFX@("C",AUPNP,AUPNI,AUPNS)=""  ; SET STRUCTURED X-REF FOR DISPLAY

 . . S ^AUPNTMP("CURRENT")=$NA(@AUPNFX@(AUPNS))  ; SET CURRENT NODE

 . . I AUPNV M @AUPNFX@(AUPNS)=AUPNE(AUPNO) K AUPNE(AUPNO)  ; STORE WARNINGS IF OVERRIDE WAS USED

 . . D AUPN(AUPNI,AUPNO,$NA(@AUPNFX@(AUPNS)))  ; PROCESS AUPN CLEANUP

 . . S AUPNCHG=1

 . . D ANC(AUPNFX,AUPNS)  ; RUN ANCILLARY CLEANUPS

 . . K ^AUPNTMP("CURRENT")

 . ; IF NO ENTRIES CHANGED, STORE ALL ERRORS/WARNINGS FOR THE RECORD

 . I 'AUPNCHG,$D(AUPNE) S AUPNO=0 F  S AUPNO=$O(AUPNE(AUPNO)) Q:'AUPNO  M @AUPNEX@(AUPNP,AUPNI,AUPNO)=AUPNE(AUPNO) D INC(AUPNEX)

 Q

 ;

CHKONE(AUPNI,AUPNO,AUPNR,AUPNV) ; DATA INTEGRITY CHECK, OVERRIDE WILL IGNORE COVERAGE OVERLAP WARNINGS

 N AUPNN,AUPNC,AUPND,AUPNT,AUPNT2

 S AUPNI=$G(AUPNI),AUPNO=$G(AUPNO),AUPNR=$G(AUPNR),AUPNV=+$G(AUPNV),(AUPNT,AUPNT2)=0 Q:'AUPNI  Q:'AUPNO

 S AUPNN=$G(^AUPNMCD(AUPNI,11,AUPNO,0)) Q:AUPNN']""

 S AUPNC=0 F  S AUPNC=$O(^AUPNMCD(AUPNI,11,AUPNC)) Q:'AUPNC  D

 . S AUPND=$G(^AUPNMCD(AUPNI,11,AUPNC,0)) S:'$P(AUPND,U,2) $P(AUPND,U,2)=9999999

 . S:+AUPNN=AUPNC @AUPNR@(AUPNO,"E","TARGET EXISTS")=$G(@AUPNR@(AUPNO,"E","TARGET EXISTS"))_AUPNC_U,AUPNT=AUPNT+1

 . Q:+AUPND'=AUPNC  ; SKIP IF ENTRY NOT DINUMED

 . Q:$P(AUPNN,U,3)'=$P(AUPND,U,3)  ; SKIP IF COV IS DIFF

 . S:+AUPNN=$P(AUPND,U,2) @AUPNR@(AUPNO,"W","OVERLAP-END DATE")=$G(@AUPNR@(AUPNO,"W","OVERLAP-END DATE"))_AUPNC_U,AUPNT2=AUPNT2+1

 . S:(+AUPNN>+AUPND)&(+AUPNN<$P(AUPND,U,2)) @AUPNR@(AUPNO,"W","OVERLAP-RANGE")=$G(@AUPNR@(AUPNO,"W","OVERLAP-RANGE"))_AUPNC_U,AUPNT2=AUPNT2+1

 Q $S(AUPNT+$S('AUPNV:AUPNT2,1:0):1,1:0)  ; IF OVERRIDE ONLY COUNT ERRORS, OTHERWISE COUNT ERRORS AND WARNINGS

 ;

CHKPREV ; CHECK IF ANCILLARIES RAN ON CORRECTED RECORDS

 N AUPNFX,AUPNS,AUPNS2,AUPNT,AUPNA,AUPNC,AUPNR

 Q:'+$$GETFIX

 S AUPNFX=$NA(^AUPNTMP("FIXED")),AUPNT=$$GETANC

 W !,"Scanning corrected records for additional cleanup"

 S AUPNS=0 F  S AUPNR="",AUPNS=$O(@AUPNFX@(AUPNS)) Q:'AUPNS  D

 . F AUPNC=1:1:$L(AUPNT,U) S AUPNA=$P(AUPNT,U,AUPNC) Q:AUPNA']""  D

 . . Q:'$L($$GETANC(AUPNA,"R"))

 . . Q:'$L($T(@($$GETANC(AUPNA,"R"))))  Q:$$GETANC(AUPNA,"V")'>$G(@AUPNFX@(AUPNS,AUPNA))

 . . W !,?2,"Ancillary cleanup (",AUPNA,") did not run on: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T"))

 . . S:$$ASK("  Run "_AUPNA_" cleanup?","Y") AUPNR=AUPNR_AUPNA_U

 . Q:AUPNR']""

 . W !,?4,"Processing (",$TR($E(AUPNR,1,$L(AUPNR)-1),U,","),") cleanup on ",$$GETFIX(AUPNS,"C")," records..."

 . S AUPNS2=0 F  S AUPNS2=$O(@AUPNFX@(AUPNS,AUPNS2)) Q:'AUPNS2  D

 . . S ^AUPNTMP("CURRENT")=$NA(@AUPNFX@(AUPNS,AUPNS2))

 . . D ANC($NA(@AUPNFX@(AUPNS)),AUPNS2,AUPNR)

 . . K ^AUPNTMP("CURRENT")

 Q

 ;

AUPN(AUPNI,AUPNO,AUPNFX) ; AUPN MAIN CLEANUP

 N AUPNN,AUPNT,FDA,FDAIEN,ERR

 S AUPNI=$G(AUPNI),AUPNO=$G(AUPNO),AUPNFX=$G(AUPNFX) Q:'AUPNI  Q:'AUPNO

 S AUPNN=$G(^AUPNMCD(AUPNI,11,AUPNO,0)) Q:AUPNN']""

 K FDA,ERR

 S FDA(9000004.11,AUPNO_","_AUPNI_",",.01)="@"

 D FILE^DIE(,"FDA","ERR")  ; DELETE OLD RECORD FIRST (OTHERWISE X-REFS MAY BREAK)

 I $D(ERR) M @AUPNFX@("ERR","DEL")=ERR

 K FDA,FDAIEN,ERR

 S FDA(9000004.11,"+1,"_AUPNI_",",.01)=$P(AUPNN,U)

 S FDA(9000004.11,"+1,"_AUPNI_",",.02)=$P(AUPNN,U,2)

 S FDA(9000004.11,"+1,"_AUPNI_",",.03)=$P(AUPNN,U,3)

 S FDAIEN(1)=$P(AUPNN,U)

 D UPDATE^DIE(,"FDA","FDAIEN","ERR")  ; CREATE NEW RECORD

 S:$G(FDAIEN(1))'=$P(AUPNN,U) @AUPNFX@("ERR","ADD")="IEN MISMATCH: "_$G(FDAIEN(1))

 I $D(ERR) M @AUPNFX@("ERR","ADD")=ERR

 ; UPDATE DATE LATE UPDATED FIELD

 S AUPNT=$$GET1^DIQ(9000004,AUPNI,.08,"I")

 I AUPNT'=$$DT^XLFDT D

 . K FDA

 . S FDA(9000004,AUPNI_",",.08)=$$DT^XLFDT

 . D LOG(9000004,AUPNI,.08,AUPNT),UPDATE^DIE(,"FDA")

 Q

 ;

ANC(AUPNFX,AUPNS,AUPNAL) ; RUN ANCILLARY CLEANUP ROUTINES

 ; ANCILLARY LIST DEFAULTS TO ALL, CAN BE USED TO SEND SPECIFIC CLEANUPS (CHKPREV)

 N AUPNRO,AUPNVR,AUPND,AUPNP,AUPNI,AUPNO,AUPNN,AUPNC,AUPNA

 S AUPNFX=$G(AUPNFX),AUPNS=+$G(AUPNS) Q:'$D(@AUPNFX)  Q:'AUPNS

 S AUPNAL=$S($L($G(AUPNAL)):$G(AUPNAL),1:$$GETANC)

 F AUPNC=1:1:$L(AUPNAL,U) S AUPNA=$P(AUPNAL,U,AUPNC) Q:AUPNA']""  D

 . S AUPNRO=$$GETANC(AUPNA,"R"),AUPNVR=$$GETANC(AUPNA,"V") Q:AUPNRO']""  Q:'$L($T(@AUPNRO))

 . S AUPND=$G(@AUPNFX@(AUPNS)) Q:AUPND']""

 . S AUPNP=$P(AUPND,U),AUPNI=$P(AUPND,U,2),AUPNO=$P(AUPND,U,3),AUPNN=$P(AUPND,U,4)

 . D @(AUPNRO_"(AUPNP,AUPNI,AUPNO,AUPNN)")

 . S:$G(@AUPNFX@(AUPNA))'=AUPNVR @AUPNFX@(AUPNA)=AUPNVR

 . D ^XBFMK

 Q

 ;

RPT1 ; SUMMARY REPORT

 N AUPNFX,AUPNS,AUPNI,AUPND,AUPNDT,AUPNA,AUPNW

 N AUPNP,AUPNI,AUPNS2

 Q:'+$$GETFIX

 W !!,$$CJ^XLFSTR("REPORT (CORRECTED RECORDS)",80),!,$$REPEAT^XLFSTR("*",80)

 S AUPNS=0 F  S AUPNS=$O(^AUPNTMP("FIXED",AUPNS)) Q:'AUPNS  D

 . S AUPNFX=$NA(^AUPNTMP("FIXED",AUPNS))

 . W !,AUPNS,")",?4,"Run Date: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T")),?40,"User: ",$$GETFIX(AUPNS,"U"),?60,"Override: ",$S($$GETFIX(AUPNS,"O"):"YES",1:"NO"),!

 . S AUPNP=0 F  S AUPNP=$O(@AUPNFX@("C",AUPNP)) Q:'AUPNP  W !,?2,"Patient: ",AUPNP D

 . . S AUPNI=0 F  S AUPNI=$O(@AUPNFX@("C",AUPNP,AUPNI)) Q:'AUPNI  W ?21,"MCD Entry: ",AUPNI D

 . . . S AUPNS2=0 F  S AUPNS2=$O(@AUPNFX@("C",AUPNP,AUPNI,AUPNS2)) Q:'AUPNS2  D  W !

 . . . . W ?39,"Old: ",$P($G(@AUPNFX@(AUPNS2)),U,3),?56,"New: ",$P($G(@AUPNFX@(AUPNS2)),U,4)

 . . . . I $D(@AUPNFX@(AUPNS2,"W")) W ?75,"OVR"

 Q

 ;

RPT2 ; DETAILED REPORT

 N AUPNFX,AUPNS,AUPNI,AUPNI2,AUPND,AUPNDT,AUPNA,AUPNFL,AUPNF,AUPNT,AUPNT2

 Q:'+$$GETFIX

 W !!,$$CJ^XLFSTR("REPORT (CORRECTED RECORDS - DETAILED)",80),!,$$REPEAT^XLFSTR("*",80)

 S AUPNF=$$ASK("Print additional info","Y")  ; DISPLAYS INDIVIDUAL RECORDS PER FILE

 S AUPNS=0 F  S AUPNS=$O(^AUPNTMP("FIXED",AUPNS)) Q:'AUPNS  D

 . S AUPNFX=$NA(^AUPNTMP("FIXED",AUPNS))

 . W !,AUPNS,")",?4,"Run Date: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T")),?40,"User: ",$$GETFIX(AUPNS,"U"),?60,"Override: ",$S($$GETFIX(AUPNS,"O"):"Yes",1:"No"),!

 . S AUPNP=0 F  S AUPNP=$O(@AUPNFX@("C",AUPNP)) Q:'AUPNP  D

 . . S AUPNI=0 F  S AUPNI=$O(@AUPNFX@("C",AUPNP,AUPNI)) Q:'AUPNI  D

 . . . W !,"Patient: ",AUPNP,?20,"MCD Entry: ",AUPNI

 . . . S AUPNS2=0 F  S AUPNS2=$O(@AUPNFX@("C",AUPNP,AUPNI,AUPNS2)) Q:'AUPNS2  D

 . . . . I +$G(@AUPNFX@(AUPNS2,9000004,0)) W ?40,"Last updated: ",$$FMTE^XLFDT($P($G(@AUPNFX@(AUPNS2,9000004,1)),";",3))

 . . . . W !,?2,"* Old: ",$P($G(@AUPNFX@(AUPNS2)),U,3),?22,"New: ",$P($G(@AUPNFX@(AUPNS2)),U,4)

 . . . . S AUPNFL=0 F  S AUPNFL=$O(@AUPNFX@(AUPNS2,AUPNFL)) Q:'AUPNFL  D

 . . . . . Q:'+$G(@AUPNFX@(AUPNS2,AUPNFL,0))!(AUPNFL=9000004)

 . . . . . W !,?4,"  ",+$G(@AUPNFX@(AUPNS2,AUPNFL,0))," addtl record(s) from ",$$TITLE^XLFSTR($$GET1^DID(AUPNFL,,,"NAME"))," file (#",AUPNFL,")"

 . . . . . Q:'AUPNF

 . . . . . S AUPNI2=0 F  S AUPNI2=$O(@AUPNFX@(AUPNS2,AUPNFL,AUPNI2)) Q:'AUPNI2  D

 . . . . . . S AUPND=$G(@AUPNFX@(AUPNS2,AUPNFL,AUPNI2))

 . . . . . . I AUPNI2=1 D

 . . . . . . . S AUPNT=$S($P(AUPND,";",2)[",":$P($P(AUPND,";",2),","),1:AUPNFL)

 . . . . . . . S AUPNT2=$S($P(AUPND,";",2)[",":$P($P(AUPND,";",2),",",2),1:$P(AUPND,";",2))

 . . . . . . . W !,?8

 . . . . . . . I AUPNT'=AUPNFL W $$TITLE^XLFSTR($P($G(^DD(AUPNT,0)),U))," (#",AUPNT,"), "

 . . . . . . . W $$TITLE^XLFSTR($$GET1^DID(AUPNT,AUPNT2,,"LABEL"))," field (#",AUPNT2,")"

 . . . . . . W !,?8,"- Record: ",$P(AUPND,";") ;,?30 ;,"Field: '"

 . . . . . . W ?39,"Old: ",$P(AUPND,";",3)

 . . W !

 Q

 ;

RPT3 ; EXCLUSION REPORT

 N AUPNEX,AUPNP,AUPNI,AUPNI2,AUPNI3,AUPNEXC,AUPNTYP

 S AUPNEX=$NA(^AUPNTMP("EXCLUDE")) Q:'$D(@AUPNEX)

 W !!,$$CJ^XLFSTR("REPORT (EXCLUDED RECORDS)",80),!,$$REPEAT^XLFSTR("*",80)

 W !,?10,"PATIENT",?20,"RECORD",?30,"ENTRY",?40,"TYPE",?50,"REASON",?65,"CONFLICT ENTRY"

 W !,?10,"-------",?20,"------",?30,"-----",?40,"----",?50,"------",?65,"--------------"

 S AUPNP=0 F  S AUPNP=$O(@AUPNEX@(AUPNP)) Q:'AUPNP  W !,?10,AUPNP D

 . S AUPNI=0 F  S AUPNI=$O(@AUPNEX@(AUPNP,AUPNI)) Q:'AUPNI  W ?20,AUPNI D

 . . S AUPNI2=0 F  S AUPNI2=$O(@AUPNEX@(AUPNP,AUPNI,AUPNI2)) Q:'AUPNI2  W ?30,AUPNI2 D

 . . . S AUPNTYP="" F  S AUPNTYP=$O(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP)) Q:AUPNTYP']""  W ?40,$S(AUPNTYP="E":"ERROR",AUPNTYP="W":"WARNING",1:"") D

 . . . . S AUPNEXC="" F  S AUPNEXC=$O(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC)) Q:AUPNEXC']""  W ?50,AUPNEXC D

 . . . . . F AUPNI3=1:1:$L($G(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC)),U)-1 W ?65,$P($G(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC)),U,AUPNI3),!

 Q

 ;

SETANC ; BUILD ANCILLARY GLOBAL

 N AUPNC,AUPNT,AUPNA,AUPND

 F AUPNC=1:1 S AUPNT=$P($T(ANCIL+AUPNC),";;",2) Q:AUPNT="END"  D

 . S AUPNA=$P(AUPNT,";"),AUPND=$P(AUPNT,";",2) Q:AUPNA']""

 . S:+$P($G(^AUPNTMP("ANCILLARY",AUPNA)),U)<$P(AUPND,U) ^AUPNTMP("ANCILLARY",AUPNA)=AUPND

 Q

 ;

GETANC(AUPNA,AUPNF) ; REPLACE GLOBAL READ

 ; FLAG=(V)ERSION, (R)OUTINE, DEFAULTS TO BOTH

 N AUPNC,AUPNR

 S AUPNA=$G(AUPNA),AUPNF=$G(AUPNF),AUPNR=""

 S AUPNC="" F  S AUPNC=$O(^AUPNTMP("ANCILLARY",AUPNC)) Q:AUPNC']""  D

 . I AUPNA']"" S AUPNR=AUPNR_AUPNC_U Q

 . S:AUPNA=AUPNC AUPNR=$G(^AUPNTMP("ANCILLARY",AUPNA)),AUPNR=$S(AUPNF="V":$P(AUPNR,U),AUPNF="R":$P(AUPNR,U,2,3),1:AUPNR)

 Q AUPNR

 ;

GETFIX(AUPNS,AUPNF) ; REPLACE GLOBAL READ

 ; FLAG=(C)OUNT, DA(T)E, (U)SER, (O)VERRIDE, DEFAULTS TO ALL

 N AUPNR

 S AUPNS=+$G(AUPNS),AUPNF=$G(AUPNF),AUPNR=""

 S AUPNR=$S(AUPNS:$G(^AUPNTMP("FIXED",AUPNS,0)),1:$G(^AUPNTMP("FIXED",0)))

 S AUPNR=$S(AUPNF="C":+$P(AUPNR,U),AUPNF="T":$P(AUPNR,U,2),AUPNF="U":$P(AUPNR,U,3),AUPNF="O":$P(AUPNR,U,4),1:AUPNR)

 Q AUPNR

 ;

LOG(AUPNFL,AUPNI,AUPNFLD,AUPNO) ; EP - LOG RESULTS

 ; FL=FILE I=IEN FLD=FIELD # O=OLD VALUE

 N AUPNFX

 S AUPNFL=$G(AUPNFL),AUPNI=$G(AUPNI),AUPNFLD=$G(AUPNFLD),AUPNO=$G(AUPNO),AUPNFX=$G(^AUPNTMP("CURRENT")) Q:AUPNFX']""  Q:AUPNFL']""

 D INC($NA(@AUPNFX@(AUPNFL,0)))

 S @AUPNFX@(AUPNFL,$G(@AUPNFX@(AUPNFL,0)))=AUPNI_";"_AUPNFLD_";"_AUPNO

 Q

 ;

INC(RES,CNT,SUB) ; INCREMENT A TOTAL

 I +$G(SUB) S $P(@RES,U,+$G(SUB))=+$P(@RES,U,+$G(SUB))+$S(+$G(CNT):+$G(CNT),1:1) Q

 S @RES=+$G(@RES)+$S(+$G(CNT):+$G(CNT),1:1)

 Q

 ;

ASK(MSG,DEF) ; PROMPT USER INPUT

 Q:$D(AUPNQ) $S($G(DEF)="Y":1,1:0)

 N DIR,Y

 S DIR(0)="Y",DIR("B")=$S($G(DEF)]"":$G(DEF),1:"N")

 S DIR("A")=$G(MSG)_" (Y/N)"

 D ^DIR K DIR

 Q $S($G(Y)=1:1,1:0)

 ;

CONT ; PROMPT TO CONTINUE

 Q:$D(AUPNQ)

 K DIR S DIR(0)="EO",DIR("A")="Press Enter to continue." D ^DIR K DIR Q

 ;

ANCIL ; LIST OF ANCILLARY CLEANUPS

 ;;AG;1^EN^AG9924

 ;;ABM;1^EN^ABMMCDCU

 ;;ACHS;1^EN^ACHSDM

 ;;END

AUPNMCDF  ;IHS/OIT/NKD - MCD Eligiblity fix ; 02/19/2015

 +1       ;;99.1;IHS DICTIONARIES (PATIENT);**24**;MAR 9, 1999;Build 1

 +2       ; 

 +3       ; VARIABLE NAMING SCHEME:

 +4       ;  SC=SCAN GLOBAL, FX=FIX GLOBAL, EX=EXCLUDE GLOBAL

 +5       ;  P=PATIENT IEN, I=RECORD IEN, I2=SUB-RECORD IEN, O=OLD VALUE, N=NEW VALUE

 +6       ;  A=ANCILLARY, AL=ANCILLARY LIST, RO=ROUTINE, VR=VERSION

 +7       ;  S=SEQUENCE, V=OVERRIDE, F=FLAG, FL=FILE, FLD=FIELD, DT=DATE

 +8       ;  C=COUNT/ITERATOR, D=DATA, T=TEMP, R=RESULT, Q=QUIET

 +9       ;

 +10       NEW AUPNQ

           SET AUPNQ=1

 +11       DO SETANC

           DO SCAN

           DO RPT1

           DO RPT2

           DO RPT3

 +12       QUIT 

 +13      ;

MAIN      ; EP - MAIN MENU

 +1        NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT

 +2        DO SETANC

 +3        FOR 

               IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)

                   QUIT 

               Begin DoDot:1

 +4                WRITE !!,?8,"Medicaid Eligibility Fix"

 +5                WRITE !,?23,"Scan last run at: ",$SELECT($GET(^AUPNTMP("SCAN","DT")):$$FMTE^XLFDT($GET(^AUPNTMP("SCAN","DT"))),1:"Never")

 +6                WRITE !,?10,"(S)can",?25,"Scan and fix corrupt entries"

 +7                WRITE !,?10,"(V)erify",?25,"Verify results of previous scans"

 +8                WRITE !,?10,"(R)esults",?25,"Display scan results"

 +9                SET DIR(0)="SAO^S:SCAN;V:VERIFY;R:RESULTS"

 +10               SET DIR("A")="(S)CAN, (V)ERIFY, (R)ESULTS: "

 +11               DO ^DIR

 +12               IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)

                       QUIT 

 +13               IF $GET(Y)="S"

                       DO SCAN

                       DO CONT

 +14              IF '$TEST

                       IF $GET(Y)="V"

                           DO CHKPREV

                           DO CONT

 +15              IF '$TEST

                       IF $GET(Y)="R"

                           DO RPT1

                           DO CONT

                           DO RPT2

                           DO CONT

                           DO RPT3

                           DO CONT

 +16               KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT

               End DoDot:1

 +17       QUIT 

 +18      ;

SCAN      ; SCAN MCD ELIGIBILITY RECORDS FOR NON-DINUMED SUB-RECORDS

 +1        NEW AUPNSC,AUPNI,AUPNI2,AUPNDT,AUPNR,AUPNP

 +2        SET AUPNSC=$NAME(^AUPNTMP("SCAN"))

           KILL @AUPNSC

 +3        WRITE !!,"Scanning AUPNMCD global"

 +4        SET @AUPNSC@("DT")=$$NOW^XLFDT

 +5        SET AUPNI=0

           FOR 

               SET AUPNI=$ORDER(^AUPNMCD(AUPNI))

               IF 'AUPNI

                   QUIT 

               Begin DoDot:1

 +6                SET AUPNP=$PIECE($GET(^AUPNMCD(AUPNI,0)),U)

                   IF 'AUPNP

                       QUIT 

 +7                DO INC($NAME(@AUPNSC@("TOT")))

                   IF '($GET(@AUPNSC@("TOT"))#5000)

                       WRITE "."

 +8                SET AUPNI2=0

                   FOR 

                       SET AUPNI2=$ORDER(^AUPNMCD(AUPNI,11,AUPNI2))

                       IF 'AUPNI2

                           QUIT 

                       Begin DoDot:2

 +9                        SET AUPNDT=$PIECE($GET(^AUPNMCD(AUPNI,11,AUPNI2,0)),U)

                           IF AUPNDT=AUPNI2

                               QUIT 

 +10      ; SKIP IF NOT A DATE

                           IF AUPNDT'?7N

                               DO INC($NAME(@AUPNSC@("ERR")))

                               QUIT 

 +11                       IF '$DATA(@AUPNSC@(AUPNP))

                               DO INC($NAME(@AUPNSC@("PAT")))

 +12                       IF '$DATA(@AUPNSC@(AUPNP,AUPNI))

                               DO INC($NAME(@AUPNSC@("REC")))

 +13                       DO INC($NAME(@AUPNSC@("SUB")))

 +14                       SET @AUPNSC@(AUPNP,AUPNI)=""

                       End DoDot:2

               End DoDot:1

 +15       WRITE "Completed!",?40,"Total records scanned: ",+$GET(@AUPNSC@("TOT"))

 +16       IF '+$GET(@AUPNSC@("REC"))

               WRITE !,"No issues found to correct!"

               QUIT 

 +17       WRITE !,?10,"Record count: ",+$GET(@AUPNSC@("REC")),?40,"Entry count: ",+$GET(@AUPNSC@("SUB"))

 +18       IF '$GET(@AUPNSC@("OLD"))

               IF $$ASK("Proceed with correction","Y")

                   DO PRC

 +19       QUIT 

 +20      ;

PRC       ; PROCESS RESULTS FROM A SCAN

 +1        NEW AUPNSC,AUPNFX,AUPNEX,AUPNP,AUPNI,AUPNV

 +2        SET AUPNSC=$NAME(^AUPNTMP("SCAN"))

 +3        DO INC($NAME(^AUPNTMP("FIXED",0)))

 +4        SET AUPNFX=$NAME(^AUPNTMP("FIXED",+$$GETFIX))

           SET AUPNEX=$NAME(^AUPNTMP("EXCLUDE"))

           KILL @AUPNEX

 +5        SET AUPNV=$$ASK("Override coverage overlap checks","Y")

 +6        WRITE !!,"Processing ",$GET(@AUPNSC@("SUB"))," entries in the MEDICAID ELIGIBILE file..."

 +7       ; STORE ENTRY COUNT, DATE/TIME, USER, AND OVERRIDE

           SET @AUPNFX@(0)="0"_U_$$NOW^XLFDT_U_DUZ_U_AUPNV

 +8        SET AUPNP=0

           FOR 

               SET AUPNP=$ORDER(@AUPNSC@(AUPNP))

               IF 'AUPNP

                   QUIT 

               Begin DoDot:1

 +9                SET AUPNI=0

                   FOR 

                       SET AUPNI=$ORDER(@AUPNSC@(AUPNP,AUPNI))

                       IF 'AUPNI

                           QUIT 

                       Begin DoDot:2

 +10                       DO REC(AUPNP,AUPNI,AUPNFX,AUPNEX,AUPNV)

                       End DoDot:2

               End DoDot:1

 +11       WRITE "Completed!"

 +12       IF +$GET(@AUPNFX@(0))

               WRITE !,+$GET(@AUPNFX@(0))," entries successfully processed"

 +13       IF +$GET(@AUPNEX)

               WRITE !,+$GET(@AUPNEX)," entries were excluded - See report for details"

 +14       QUIT 

 +15      ;

REC(AUPNP,AUPNI,AUPNFX,AUPNEX,AUPNV) ; PROCESS A SINGLE RECORD

 +1        NEW AUPNO,AUPNN,AUPNS,AUPNCHG,AUPNA,AUPNRO

 +2        SET AUPNP=$GET(AUPNP)

           SET AUPNI=$GET(AUPNI)

           SET AUPNFX=$GET(AUPNFX)

           SET AUPNEX=$GET(AUPNEX)

           SET AUPNV=+$GET(AUPNV)

           SET AUPNCHG=1

           IF 'AUPNP

               QUIT 

           IF 'AUPNI

               QUIT 

 +3       ; LOOP UNTIL NO SUB-RECORDS CHANGED - SEQUENCE/ORDER REQUIRED FOR CORRECTION

           FOR 

               IF 'AUPNCHG

                   QUIT 

               Begin DoDot:1

 +4                NEW AUPNE

 +5                SET (AUPNCHG,AUPNO)=0

                   FOR 

                       SET AUPNO=$ORDER(^AUPNMCD(AUPNI,11,AUPNO))

                       IF 'AUPNO

                           QUIT 

                       Begin DoDot:2

 +6                        SET AUPNN=$PIECE($GET(^AUPNMCD(AUPNI,11,AUPNO,0)),U)

                           IF AUPNO=AUPNN!(AUPNN'?7N)

                               QUIT 

 +7                        IF $$CHKONE(AUPNI,AUPNO,"AUPNE",AUPNV)

                               QUIT 

 +8                        DO INC($NAME(@AUPNFX@(0)),,1)

                           SET AUPNS=+$GET(@AUPNFX@(0))

 +9       ; LOG SUB-RECORD CHANGED

                           SET @AUPNFX@(AUPNS)=AUPNP_U_AUPNI_U_AUPNO_U_AUPNN

 +10      ; SET STRUCTURED X-REF FOR DISPLAY

                           SET @AUPNFX@("C",AUPNP,AUPNI,AUPNS)=""

 +11      ; SET CURRENT NODE

                           SET ^AUPNTMP("CURRENT")=$NAME(@AUPNFX@(AUPNS))

 +12      ; STORE WARNINGS IF OVERRIDE WAS USED

                           IF AUPNV

                               MERGE @AUPNFX@(AUPNS)=AUPNE(AUPNO)

                               KILL AUPNE(AUPNO)

 +13      ; PROCESS AUPN CLEANUP

                           DO AUPN(AUPNI,AUPNO,$NAME(@AUPNFX@(AUPNS)))

 +14                       SET AUPNCHG=1

 +15      ; RUN ANCILLARY CLEANUPS

                           DO ANC(AUPNFX,AUPNS)

 +16                       KILL ^AUPNTMP("CURRENT")

                       End DoDot:2

 +17      ; IF NO ENTRIES CHANGED, STORE ALL ERRORS/WARNINGS FOR THE RECORD

 +18               IF 'AUPNCHG

                       IF $DATA(AUPNE)

                           SET AUPNO=0

                           FOR 

                               SET AUPNO=$ORDER(AUPNE(AUPNO))

                               IF 'AUPNO

                                   QUIT 

                               MERGE @AUPNEX@(AUPNP,AUPNI,AUPNO)=AUPNE(AUPNO)

                               DO INC(AUPNEX)

               End DoDot:1

 +19       QUIT 

 +20      ;

CHKONE(AUPNI,AUPNO,AUPNR,AUPNV) ; DATA INTEGRITY CHECK, OVERRIDE WILL IGNORE COVERAGE OVERLAP WARNINGS

 +1        NEW AUPNN,AUPNC,AUPND,AUPNT,AUPNT2

 +2        SET AUPNI=$GET(AUPNI)

           SET AUPNO=$GET(AUPNO)

           SET AUPNR=$GET(AUPNR)

           SET AUPNV=+$GET(AUPNV)

           SET (AUPNT,AUPNT2)=0

           IF 'AUPNI

               QUIT 

           IF 'AUPNO

               QUIT 

 +3        SET AUPNN=$GET(^AUPNMCD(AUPNI,11,AUPNO,0))

           IF AUPNN']""

               QUIT 

 +4        SET AUPNC=0

           FOR 

               SET AUPNC=$ORDER(^AUPNMCD(AUPNI,11,AUPNC))

               IF 'AUPNC

                   QUIT 

               Begin DoDot:1

 +5                SET AUPND=$GET(^AUPNMCD(AUPNI,11,AUPNC,0))

                   IF '$PIECE(AUPND,U,2)

                       SET $PIECE(AUPND,U,2)=9999999

 +6                IF +AUPNN=AUPNC

                       SET @AUPNR@(AUPNO,"E","TARGET EXISTS")=$GET(@AUPNR@(AUPNO,"E","TARGET EXISTS"))_AUPNC_U