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
SET AUPNT=AUPNT+1
+7 ; SKIP IF ENTRY NOT DINUMED
IF +AUPND'=AUPNC
QUIT
+8 ; SKIP IF COV IS DIFF
IF $PIECE(AUPNN,U,3)'=$PIECE(AUPND,U,3)
QUIT
+9 IF +AUPNN=$PIECE(AUPND,U,2)
SET @AUPNR@(AUPNO,"W","OVERLAP-END DATE")=$GET(@AUPNR@(AUPNO,"W","OVERLAP-END DATE"))_AUPNC_U
SET AUPNT2=AUPNT2+1
+10 IF (+AUPNN>+AUPND)&(+AUPNN<$PIECE(AUPND,U,2))
SET @AUPNR@(AUPNO,"W","OVERLAP-RANGE")=$GET(@AUPNR@(AUPNO,"W","OVERLAP-RANGE"))_AUPNC_U
SET AUPNT2=AUPNT2+1
End DoDot:1
+11 ; IF OVERRIDE ONLY COUNT ERRORS, OTHERWISE COUNT ERRORS AND WARNINGS
QUIT $SELECT(AUPNT+$SELECT('AUPNV:AUPNT2,1:0):1,1:0)
+12 ;
CHKPREV ; CHECK IF ANCILLARIES RAN ON CORRECTED RECORDS
+1 NEW AUPNFX,AUPNS,AUPNS2,AUPNT,AUPNA,AUPNC,AUPNR
+2 IF '+$$GETFIX
QUIT
+3 SET AUPNFX=$NAME(^AUPNTMP("FIXED"))
SET AUPNT=$$GETANC
+4 WRITE !,"Scanning corrected records for additional cleanup"
+5 SET AUPNS=0
FOR
SET AUPNR=""
SET AUPNS=$ORDER(@AUPNFX@(AUPNS))
IF 'AUPNS
QUIT
Begin DoDot:1
+6 FOR AUPNC=1:1:$LENGTH(AUPNT,U)
SET AUPNA=$PIECE(AUPNT,U,AUPNC)
IF AUPNA']""
QUIT
Begin DoDot:2
+7 IF '$LENGTH($$GETANC(AUPNA,"R"))
QUIT
+8 IF '$LENGTH($TEXT(@($$GETANC(AUPNA,"R"))))
QUIT
IF $$GETANC(AUPNA,"V")'>$GET(@AUPNFX@(AUPNS,AUPNA))
QUIT
+9 WRITE !,?2,"Ancillary cleanup (",AUPNA,") did not run on: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T"))
+10 IF $$ASK(" Run "_AUPNA_" cleanup?","Y")
SET AUPNR=AUPNR_AUPNA_U
End DoDot:2
+11 IF AUPNR']""
QUIT
+12 WRITE !,?4,"Processing (",$TRANSLATE($EXTRACT(AUPNR,1,$LENGTH(AUPNR)-1),U,","),") cleanup on ",$$GETFIX(AUPNS,"C")," records..."
+13 SET AUPNS2=0
FOR
SET AUPNS2=$ORDER(@AUPNFX@(AUPNS,AUPNS2))
IF 'AUPNS2
QUIT
Begin DoDot:2
+14 SET ^AUPNTMP("CURRENT")=$NAME(@AUPNFX@(AUPNS,AUPNS2))
+15 DO ANC($NAME(@AUPNFX@(AUPNS)),AUPNS2,AUPNR)
+16 KILL ^AUPNTMP("CURRENT")
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
AUPN(AUPNI,AUPNO,AUPNFX) ; AUPN MAIN CLEANUP
+1 NEW AUPNN,AUPNT,FDA,FDAIEN,ERR
+2 SET AUPNI=$GET(AUPNI)
SET AUPNO=$GET(AUPNO)
SET AUPNFX=$GET(AUPNFX)
IF 'AUPNI
QUIT
IF 'AUPNO
QUIT
+3 SET AUPNN=$GET(^AUPNMCD(AUPNI,11,AUPNO,0))
IF AUPNN']""
QUIT
+4 KILL FDA,ERR
+5 SET FDA(9000004.11,AUPNO_","_AUPNI_",",.01)="@"
+6 ; DELETE OLD RECORD FIRST (OTHERWISE X-REFS MAY BREAK)
DO FILE^DIE(,"FDA","ERR")
+7 IF $DATA(ERR)
MERGE @AUPNFX@("ERR","DEL")=ERR
+8 KILL FDA,FDAIEN,ERR
+9 SET FDA(9000004.11,"+1,"_AUPNI_",",.01)=$PIECE(AUPNN,U)
+10 SET FDA(9000004.11,"+1,"_AUPNI_",",.02)=$PIECE(AUPNN,U,2)
+11 SET FDA(9000004.11,"+1,"_AUPNI_",",.03)=$PIECE(AUPNN,U,3)
+12 SET FDAIEN(1)=$PIECE(AUPNN,U)
+13 ; CREATE NEW RECORD
DO UPDATE^DIE(,"FDA","FDAIEN","ERR")
+14 IF $GET(FDAIEN(1))'=$PIECE(AUPNN,U)
SET @AUPNFX@("ERR","ADD")="IEN MISMATCH: "_$GET(FDAIEN(1))
+15 IF $DATA(ERR)
MERGE @AUPNFX@("ERR","ADD")=ERR
+16 ; UPDATE DATE LATE UPDATED FIELD
+17 SET AUPNT=$$GET1^DIQ(9000004,AUPNI,.08,"I")
+18 IF AUPNT'=$$DT^XLFDT
Begin DoDot:1
+19 KILL FDA
+20 SET FDA(9000004,AUPNI_",",.08)=$$DT^XLFDT
+21 DO LOG(9000004,AUPNI,.08,AUPNT)
DO UPDATE^DIE(,"FDA")
End DoDot:1
+22 QUIT
+23 ;
ANC(AUPNFX,AUPNS,AUPNAL) ; RUN ANCILLARY CLEANUP ROUTINES
+1 ; ANCILLARY LIST DEFAULTS TO ALL, CAN BE USED TO SEND SPECIFIC CLEANUPS (CHKPREV)
+2 NEW AUPNRO,AUPNVR,AUPND,AUPNP,AUPNI,AUPNO,AUPNN,AUPNC,AUPNA
+3 SET AUPNFX=$GET(AUPNFX)
SET AUPNS=+$GET(AUPNS)
IF '$DATA(@AUPNFX)
QUIT
IF 'AUPNS
QUIT
+4 SET AUPNAL=$SELECT($LENGTH($GET(AUPNAL)):$GET(AUPNAL),1:$$GETANC)
+5 FOR AUPNC=1:1:$LENGTH(AUPNAL,U)
SET AUPNA=$PIECE(AUPNAL,U,AUPNC)
IF AUPNA']""
QUIT
Begin DoDot:1
+6 SET AUPNRO=$$GETANC(AUPNA,"R")
SET AUPNVR=$$GETANC(AUPNA,"V")
IF AUPNRO']""
QUIT
IF '$LENGTH($TEXT(@AUPNRO))
QUIT
+7 SET AUPND=$GET(@AUPNFX@(AUPNS))
IF AUPND']""
QUIT
+8 SET AUPNP=$PIECE(AUPND,U)
SET AUPNI=$PIECE(AUPND,U,2)
SET AUPNO=$PIECE(AUPND,U,3)
SET AUPNN=$PIECE(AUPND,U,4)
+9 DO @(AUPNRO_"(AUPNP,AUPNI,AUPNO,AUPNN)")
+10 IF $GET(@AUPNFX@(AUPNA))'=AUPNVR
SET @AUPNFX@(AUPNA)=AUPNVR
+11 DO ^XBFMK
End DoDot:1
+12 QUIT
+13 ;
RPT1 ; SUMMARY REPORT
+1 NEW AUPNFX,AUPNS,AUPNI,AUPND,AUPNDT,AUPNA,AUPNW
+2 NEW AUPNP,AUPNI,AUPNS2
+3 IF '+$$GETFIX
QUIT
+4 WRITE !!,$$CJ^XLFSTR("REPORT (CORRECTED RECORDS)",80),!,$$REPEAT^XLFSTR("*",80)
+5 SET AUPNS=0
FOR
SET AUPNS=$ORDER(^AUPNTMP("FIXED",AUPNS))
IF 'AUPNS
QUIT
Begin DoDot:1
+6 SET AUPNFX=$NAME(^AUPNTMP("FIXED",AUPNS))
+7 WRITE !,AUPNS,")",?4,"Run Date: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T")),?40,"User: ",$$GETFIX(AUPNS,"U"),?60,"Override: ",$SELECT($$GETFIX(AUPNS,"O"):"YES",1:"NO"),!
+8 SET AUPNP=0
FOR
SET AUPNP=$ORDER(@AUPNFX@("C",AUPNP))
IF 'AUPNP
QUIT
WRITE !,?2,"Patient: ",AUPNP
Begin DoDot:2
+9 SET AUPNI=0
FOR
SET AUPNI=$ORDER(@AUPNFX@("C",AUPNP,AUPNI))
IF 'AUPNI
QUIT
WRITE ?21,"MCD Entry: ",AUPNI
Begin DoDot:3
+10 SET AUPNS2=0
FOR
SET AUPNS2=$ORDER(@AUPNFX@("C",AUPNP,AUPNI,AUPNS2))
IF 'AUPNS2
QUIT
Begin DoDot:4
+11 WRITE ?39,"Old: ",$PIECE($GET(@AUPNFX@(AUPNS2)),U,3),?56,"New: ",$PIECE($GET(@AUPNFX@(AUPNS2)),U,4)
+12 IF $DATA(@AUPNFX@(AUPNS2,"W"))
WRITE ?75,"OVR"
End DoDot:4
WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
RPT2 ; DETAILED REPORT
+1 NEW AUPNFX,AUPNS,AUPNI,AUPNI2,AUPND,AUPNDT,AUPNA,AUPNFL,AUPNF,AUPNT,AUPNT2
+2 IF '+$$GETFIX
QUIT
+3 WRITE !!,$$CJ^XLFSTR("REPORT (CORRECTED RECORDS - DETAILED)",80),!,$$REPEAT^XLFSTR("*",80)
+4 ; DISPLAYS INDIVIDUAL RECORDS PER FILE
SET AUPNF=$$ASK("Print additional info","Y")
+5 SET AUPNS=0
FOR
SET AUPNS=$ORDER(^AUPNTMP("FIXED",AUPNS))
IF 'AUPNS
QUIT
Begin DoDot:1
+6 SET AUPNFX=$NAME(^AUPNTMP("FIXED",AUPNS))
+7 WRITE !,AUPNS,")",?4,"Run Date: ",$$FMTE^XLFDT($$GETFIX(AUPNS,"T")),?40,"User: ",$$GETFIX(AUPNS,"U"),?60,"Override: ",$SELECT($$GETFIX(AUPNS,"O"):"Yes",1:"No"),!
+8 SET AUPNP=0
FOR
SET AUPNP=$ORDER(@AUPNFX@("C",AUPNP))
IF 'AUPNP
QUIT
Begin DoDot:2
+9 SET AUPNI=0
FOR
SET AUPNI=$ORDER(@AUPNFX@("C",AUPNP,AUPNI))
IF 'AUPNI
QUIT
Begin DoDot:3
+10 WRITE !,"Patient: ",AUPNP,?20,"MCD Entry: ",AUPNI
+11 SET AUPNS2=0
FOR
SET AUPNS2=$ORDER(@AUPNFX@("C",AUPNP,AUPNI,AUPNS2))
IF 'AUPNS2
QUIT
Begin DoDot:4
+12 IF +$GET(@AUPNFX@(AUPNS2,9000004,0))
WRITE ?40,"Last updated: ",$$FMTE^XLFDT($PIECE($GET(@AUPNFX@(AUPNS2,9000004,1)),";",3))
+13 WRITE !,?2,"* Old: ",$PIECE($GET(@AUPNFX@(AUPNS2)),U,3),?22,"New: ",$PIECE($GET(@AUPNFX@(AUPNS2)),U,4)
+14 SET AUPNFL=0
FOR
SET AUPNFL=$ORDER(@AUPNFX@(AUPNS2,AUPNFL))
IF 'AUPNFL
QUIT
Begin DoDot:5
+15 IF '+$GET(@AUPNFX@(AUPNS2,AUPNFL,0))!(AUPNFL=9000004)
QUIT
+16 WRITE !,?4," ",+$GET(@AUPNFX@(AUPNS2,AUPNFL,0))," addtl record(s) from ",$$TITLE^XLFSTR($$GET1^DID(AUPNFL,,,"NAME"))," file (#",AUPNFL,")"
+17 IF 'AUPNF
QUIT
+18 SET AUPNI2=0
FOR
SET AUPNI2=$ORDER(@AUPNFX@(AUPNS2,AUPNFL,AUPNI2))
IF 'AUPNI2
QUIT
Begin DoDot:6
+19 SET AUPND=$GET(@AUPNFX@(AUPNS2,AUPNFL,AUPNI2))
+20 IF AUPNI2=1
Begin DoDot:7
+21 SET AUPNT=$SELECT($PIECE(AUPND,";",2)[",":$PIECE($PIECE(AUPND,";",2),","),1:AUPNFL)
+22 SET AUPNT2=$SELECT($PIECE(AUPND,";",2)[",":$PIECE($PIECE(AUPND,";",2),",",2),1:$PIECE(AUPND,";",2))
+23 WRITE !,?8
+24 IF AUPNT'=AUPNFL
WRITE $$TITLE^XLFSTR($PIECE($GET(^DD(AUPNT,0)),U))," (#",AUPNT,"), "
+25 WRITE $$TITLE^XLFSTR($$GET1^DID(AUPNT,AUPNT2,,"LABEL"))," field (#",AUPNT2,")"
End DoDot:7
+26 ;,?30 ;,"Field: '"
WRITE !,?8,"- Record: ",$PIECE(AUPND,";")
+27 WRITE ?39,"Old: ",$PIECE(AUPND,";",3)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+28 WRITE !
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
RPT3 ; EXCLUSION REPORT
+1 NEW AUPNEX,AUPNP,AUPNI,AUPNI2,AUPNI3,AUPNEXC,AUPNTYP
+2 SET AUPNEX=$NAME(^AUPNTMP("EXCLUDE"))
IF '$DATA(@AUPNEX)
QUIT
+3 WRITE !!,$$CJ^XLFSTR("REPORT (EXCLUDED RECORDS)",80),!,$$REPEAT^XLFSTR("*",80)
+4 WRITE !,?10,"PATIENT",?20,"RECORD",?30,"ENTRY",?40,"TYPE",?50,"REASON",?65,"CONFLICT ENTRY"
+5 WRITE !,?10,"-------",?20,"------",?30,"-----",?40,"----",?50,"------",?65,"--------------"
+6 SET AUPNP=0
FOR
SET AUPNP=$ORDER(@AUPNEX@(AUPNP))
IF 'AUPNP
QUIT
WRITE !,?10,AUPNP
Begin DoDot:1
+7 SET AUPNI=0
FOR
SET AUPNI=$ORDER(@AUPNEX@(AUPNP,AUPNI))
IF 'AUPNI
QUIT
WRITE ?20,AUPNI
Begin DoDot:2
+8 SET AUPNI2=0
FOR
SET AUPNI2=$ORDER(@AUPNEX@(AUPNP,AUPNI,AUPNI2))
IF 'AUPNI2
QUIT
WRITE ?30,AUPNI2
Begin DoDot:3
+9 SET AUPNTYP=""
FOR
SET AUPNTYP=$ORDER(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP))
IF AUPNTYP']""
QUIT
WRITE ?40,$SELECT(AUPNTYP="E":"ERROR",AUPNTYP="W":"WARNING",1:"")
Begin DoDot:4
+10 SET AUPNEXC=""
FOR
SET AUPNEXC=$ORDER(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC))
IF AUPNEXC']""
QUIT
WRITE ?50,AUPNEXC
Begin DoDot:5
+11 FOR AUPNI3=1:1:$LENGTH($GET(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC)),U)-1
WRITE ?65,$PIECE($GET(@AUPNEX@(AUPNP,AUPNI,AUPNI2,AUPNTYP,AUPNEXC)),U,AUPNI3),!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
SETANC ; BUILD ANCILLARY GLOBAL
+1 NEW AUPNC,AUPNT,AUPNA,AUPND
+2 FOR AUPNC=1:1
SET AUPNT=$PIECE($TEXT(ANCIL+AUPNC),";;",2)
IF AUPNT="END"
QUIT
Begin DoDot:1
+3 SET AUPNA=$PIECE(AUPNT,";")
SET AUPND=$PIECE(AUPNT,";",2)
IF AUPNA']""
QUIT
+4 IF +$PIECE($GET(^AUPNTMP("ANCILLARY",AUPNA)),U)<$PIECE(AUPND,U)
SET ^AUPNTMP("ANCILLARY",AUPNA)=AUPND
End DoDot:1
+5 QUIT
+6 ;
GETANC(AUPNA,AUPNF) ; REPLACE GLOBAL READ
+1 ; FLAG=(V)ERSION, (R)OUTINE, DEFAULTS TO BOTH
+2 NEW AUPNC,AUPNR
+3 SET AUPNA=$GET(AUPNA)
SET AUPNF=$GET(AUPNF)
SET AUPNR=""
+4 SET AUPNC=""
FOR
SET AUPNC=$ORDER(^AUPNTMP("ANCILLARY",AUPNC))
IF AUPNC']""
QUIT
Begin DoDot:1
+5 IF AUPNA']""
SET AUPNR=AUPNR_AUPNC_U
QUIT
+6 IF AUPNA=AUPNC
SET AUPNR=$GET(^AUPNTMP("ANCILLARY",AUPNA))
SET AUPNR=$SELECT(AUPNF="V":$PIECE(AUPNR,U),AUPNF="R":$PIECE(AUPNR,U,2,3),1:AUPNR)
End DoDot:1
+7 QUIT AUPNR
+8 ;
GETFIX(AUPNS,AUPNF) ; REPLACE GLOBAL READ
+1 ; FLAG=(C)OUNT, DA(T)E, (U)SER, (O)VERRIDE, DEFAULTS TO ALL
+2 NEW AUPNR
+3 SET AUPNS=+$GET(AUPNS)
SET AUPNF=$GET(AUPNF)
SET AUPNR=""
+4 SET AUPNR=$SELECT(AUPNS:$GET(^AUPNTMP("FIXED",AUPNS,0)),1:$GET(^AUPNTMP("FIXED",0)))
+5 SET AUPNR=$SELECT(AUPNF="C":+$PIECE(AUPNR,U),AUPNF="T":$PIECE(AUPNR,U,2),AUPNF="U":$PIECE(AUPNR,U,3),AUPNF="O":$PIECE(AUPNR,U,4),1:AUPNR)
+6 QUIT AUPNR
+7 ;
LOG(AUPNFL,AUPNI,AUPNFLD,AUPNO) ; EP - LOG RESULTS
+1 ; FL=FILE I=IEN FLD=FIELD # O=OLD VALUE
+2 NEW AUPNFX
+3 SET AUPNFL=$GET(AUPNFL)
SET AUPNI=$GET(AUPNI)
SET AUPNFLD=$GET(AUPNFLD)
SET AUPNO=$GET(AUPNO)
SET AUPNFX=$GET(^AUPNTMP("CURRENT"))
IF AUPNFX']""
QUIT
IF AUPNFL']""
QUIT
+4 DO INC($NAME(@AUPNFX@(AUPNFL,0)))
+5 SET @AUPNFX@(AUPNFL,$GET(@AUPNFX@(AUPNFL,0)))=AUPNI_";"_AUPNFLD_";"_AUPNO
+6 QUIT
+7 ;
INC(RES,CNT,SUB) ; INCREMENT A TOTAL
+1 IF +$GET(SUB)
SET $PIECE(@RES,U,+$GET(SUB))=+$PIECE(@RES,U,+$GET(SUB))+$SELECT(+$GET(CNT):+$GET(CNT),1:1)
QUIT
+2 SET @RES=+$GET(@RES)+$SELECT(+$GET(CNT):+$GET(CNT),1:1)
+3 QUIT
+4 ;
ASK(MSG,DEF) ; PROMPT USER INPUT
+1 IF $DATA(AUPNQ)
QUIT $SELECT($GET(DEF)="Y":1,1:0)
+2 NEW DIR,Y
+3 SET DIR(0)="Y"
SET DIR("B")=$SELECT($GET(DEF)]"":$GET(DEF),1:"N")
+4 SET DIR("A")=$GET(MSG)_" (Y/N)"
+5 DO ^DIR
KILL DIR
+6 QUIT $SELECT($GET(Y)=1:1,1:0)
+7 ;
CONT ; PROMPT TO CONTINUE
+1 IF $DATA(AUPNQ)
QUIT
+2 KILL DIR
SET DIR(0)="EO"
SET DIR("A")="Press Enter to continue."
DO ^DIR
KILL DIR
QUIT
+3 ;
ANCIL ; LIST OF ANCILLARY CLEANUPS
+1 ;;AG;1^EN^AG9924
+2 ;;ABM;1^EN^ABMMCDCU
+3 ;;ACHS;1^EN^ACHSDM
+4 ;;END
