BZXBPNA ;IHS/PHXAO/AEF - FIND BAD PATIENT NAMES
;;1.0;ANNE'S SPECIAL ROUTINES;;JUNE 10, 2004
;
;Some of the code in this routine was written by Jim Gray at PIMC,
;and rewritten by Anne Fugatt at PHXAO
;
BADPTNAM ;Find bad names
W !,"PATIENT NAME",?25,"MEDICAID NAME",?50,"MEDICARE NAME"
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
.Q:'$D(^DPT(DFN,0))
.S BZXDONE=0
.S VIEN=0
.F S VIEN=$O(^AUPNVSIT("AC",DFN,VIEN)) Q:'VIEN D Q:BZXDONE
..Q:(+$G(^AUPNVSIT(VIEN,0)))<3020214
..S FLG=0
..K NAME,MCAIDNAM,MCARNAM
..S NAME=$P(^DPT(DFN,0),U,1)
..S BZXGOOD=$$CHKNAM(NAME)
..I BZXGOOD<1 W !,NAME S FLG=1
..S MCAIDIEN=0
..F S MCAIDIEN=$O(^AUPNMCD("B",DFN,MCAIDIEN)) Q:'MCAIDIEN D
...S MCAIDNAM=$P($G(^AUPNMCD(MCAIDIEN,21)),U,1)
...I $$CHKNAM(MCAIDNAM)<1 D
....I FLG=0 W !,NAME S FLG=1
....I (MCAIDNAM="")!(MCAIDNAM?1." ") S MCAIDNAM="BLANK"
....W ?25,MCAIDNAM
..I $D(^AUPNMCR(DFN,21)) D
...S MCARNAM=$P(^AUPNMCR(DFN,21),U,1)
...I $$CHKNAM(MCARNAM)<1 D
....I FLG=0 W !,NAME S FLG=1
....I (MCARNAM="")!(MCARNAM?1." ") S MCARNAM="BLANK"
....W ?50,MCARNAM
..S BZXDONE=1
Q
;
CHKNAM(NAM) ;CHECK NAME FORMAT
I NAM?2.A.1(1" ",1"-").A1" "1(1"JR",1"SR",1"II",1"III",1"IV",1"V")1","2.A.1" ".A.1"." Q -1 ;BAD
I NAM?2.A.1(1" ",1"-").A1","1.A.1" ".A.1".".1",".3A.1"." Q 1 ;GOOD
Q 0
;
BADADR ;EP
;----- FIND BAD ADDRESSES
;
N BZXDT,BZXOUT,DIR,X,Y
D ^XBKVAR
D HOME^%ZIS
;
W !,"THIS REPORT PRINTS A LISTING OF BAD ADDRESSES IN THE VA PATIENT FILE"
W !
;
S BZXOUT=0
D CUTOFF(.BZXDT,.BZXOUT)
Q:BZXOUT
;
D PRINTA(BZXDT)
;
D QUIT
;
Q
PRINTA(BZXDT) ;
;
N BZXTITLE,ZTDESC,ZTRTN,ZTSAVE
;
S BZXTITLE="BAD ADDRESS REPORT"
S ZTRTN="DQ1^BZXBPNA"
S ZTDESC=BZXTITLE
S ZTSAVE("BZXTITLE")=""
S ZTSAVE("BZXDT")=""
D QUE^BZXBPNA(ZTRTN,.ZTSAVE,ZTDESC)
Q
DQ1 ;----- QUEUED JOB STARTS HERE
;
N BZXDONE,BZXOUT,BZXPAGE,BZXVIEN,DFN
;
S (BZXOUT,BZXPAGE)=0
D HDR(.BZXPAGE,.BZXOUT,.BZXTITLE)
Q:BZXOUT
;
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D Q:BZXOUT
. S BZXDONE=0
. S BZXVIEN=0
. F S BZXVIEN=$O(^AUPNVSIT("AC",DFN,BZXVIEN)) Q:'BZXVIEN D Q:BZXOUT Q:BZXDONE
. . Q:(+$G(^AUPNVSIT(BZXVIEN,0)))<BZXDT
. . S BZXDONE=1
. . I $Y>(IOSL-5) D HDR(.BZXPAGE,.BZXOUT,.BZXTITLE)
. . Q:BZXOUT
. . D ONE(DFN)
;
D ^%ZISC
Q
ONE(DFN) ;
;----- CHECK ONE DFN
;
N BZXADDR,BZXADDR2,BZXADDR3,BZXCITY,BZXDATA,BZXGOOD,BZXNAME,BZXSSN,BZXSTATE,BZXZIP,IENS
;
I '$D(^DPT(DFN,0)) D Q
. W !,"DFN #"_DFN_" IS MISSING A ZERO NODE"
;
S BZXGOOD=1 ;START OUT AS A GOOD ONE
S IENS=DFN_","
S BZXADDR=$$GET1^DIQ(2,IENS,.111)
I BZXADDR']"" S BZXADDR="<MISSING>",BZXGOOD=0
S BZXGOOD=$$AD1CHK(BZXADDR)
S BZXDATA=$G(^DPT(DFN,0))
S BZXNAME=$P(BZXDATA,U)
S BZXSSN=$P(BZXDATA,U,9)
S BZXDATA=$G(^DPT(DFN,.11))
S BZXADDR2=$P(BZXDATA,U,2)
S BZXADDR3=$P(BZXDATA,U,3)
S BZXCITY=$P(BZXDATA,U,4)
I BZXCITY']"" S BZXCITY="<MISSING>",BZXGOOD=0
S BZXSTATE=$$GET1^DIQ(2,IENS,.115)
I BZXSTATE']"" S BZXSTATE="<MISSING>",BZXGOOD=0
S BZXZIP=$P(BZXDATA,U,6)
I BZXZIP']"" S BZXZIP="<MISSING>",BZXGOOD=0
Q:BZXGOOD
;
W !,"("_DFN_")"
W ?12,BZXNAME,?37,BZXSSN
W !,BZXADDR
I BZXADDR2]"" W !,BZXADDR2
I BZXADDR3]"" W !,BZXADDR3
W !,BZXCITY_", "_BZXSTATE_" "_BZXZIP
W !
Q
HDR(BZXPAGE,BZXOUT,BZXTITLE) ;
;
N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
;
I $E(IOST)="C",$G(BZXPAGE) D
. S DIR(0)="E"
. D ^DIR
. I 'Y S BZXOUT=1
Q:BZXOUT
S BZXPAGE=$G(BZXPAGE)+1
W @IOF
W !,BZXTITLE
W ?49,$$NOW
W " PAGE ",BZXPAGE
W !
F I=1:1:IOM W "-"
W !!
Q
QUE(ZTRTN,ZTSAVE,ZTDESC) ;
;----- QUEUEING CODE
;
N %ZIS,IO,POP,ZTIO,ZTSK
S %ZIS="Q"
D ^%ZIS
Q:POP
I $D(IO("Q")) D Q
. K IO("Q")
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
. D ^%ZTLOAD
. I $G(ZTSK) W !,"Task #",$G(ZTSK)," queued"
D @ZTRTN
Q
CUTOFF(BZXDT,BZXOUT) ;
;----- RETURNS VISIT CUT OFF DATE
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="D^::EX"
S DIR("A")="Enter VISIT CUTOFF DATE"
S DIR("?")="The earliest VISIT DATE to include in the report"
D ^DIR
I +Y'>0 S BZXOUT=1
S BZXDT=+Y
Q
NOW() ;
;----- RETURNS CURRENT DATE/TIME
;
N %,%H,%I,X,Y
D NOW^%DTC
S Y=DT
X ^DD("DD")
Q Y_" "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)
;
AD1CHK(X) ;
;----- PATTERN MATCHES FOR ADDRESS LINE 1
;
I X?1.5N1" ".5AP.1" "3.NA.AP.N." " Q 1
I X?1"P".1".".1" "1"O".1".".1" ".1"BOX"1" ".1"#"1.8N Q 1
Q 0
QUIT ;
;----- CLEAN UP, CLOSE DEVICE, QUIT JOB
;
D ^%ZISC
Q
BZXBPNA ;IHS/PHXAO/AEF - FIND BAD PATIENT NAMES
+1 ;;1.0;ANNE'S SPECIAL ROUTINES;;JUNE 10, 2004
+2 ;
+3 ;Some of the code in this routine was written by Jim Gray at PIMC,
+4 ;and rewritten by Anne Fugatt at PHXAO
+5 ;
BADPTNAM ;Find bad names
+1 WRITE !,"PATIENT NAME",?25,"MEDICAID NAME",?50,"MEDICARE NAME"
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^DPT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 IF '$DATA(^DPT(DFN,0))
QUIT
+5 SET BZXDONE=0
+6 SET VIEN=0
+7 FOR
SET VIEN=$ORDER(^AUPNVSIT("AC",DFN,VIEN))
IF 'VIEN
QUIT
Begin DoDot:2
+8 IF (+$GET(^AUPNVSIT(VIEN,0)))<3020214
QUIT
+9 SET FLG=0
+10 KILL NAME,MCAIDNAM,MCARNAM
+11 SET NAME=$PIECE(^DPT(DFN,0),U,1)
+12 SET BZXGOOD=$$CHKNAM(NAME)
+13 IF BZXGOOD<1
WRITE !,NAME
SET FLG=1
+14 SET MCAIDIEN=0
+15 FOR
SET MCAIDIEN=$ORDER(^AUPNMCD("B",DFN,MCAIDIEN))
IF 'MCAIDIEN
QUIT
Begin DoDot:3
+16 SET MCAIDNAM=$PIECE($GET(^AUPNMCD(MCAIDIEN,21)),U,1)
+17 IF $$CHKNAM(MCAIDNAM)<1
Begin DoDot:4
+18 IF FLG=0
WRITE !,NAME
SET FLG=1
+19 IF (MCAIDNAM="")!(MCAIDNAM?1." ")
SET MCAIDNAM="BLANK"
+20 WRITE ?25,MCAIDNAM
End DoDot:4
End DoDot:3
+21 IF $DATA(^AUPNMCR(DFN,21))
Begin DoDot:3
+22 SET MCARNAM=$PIECE(^AUPNMCR(DFN,21),U,1)
+23 IF $$CHKNAM(MCARNAM)<1
Begin DoDot:4
+24 IF FLG=0
WRITE !,NAME
SET FLG=1
+25 IF (MCARNAM="")!(MCARNAM?1." ")
SET MCARNAM="BLANK"
+26 WRITE ?50,MCARNAM
End DoDot:4
End DoDot:3
+27 SET BZXDONE=1
End DoDot:2
IF BZXDONE
QUIT
End DoDot:1
+28 QUIT
+29 ;
CHKNAM(NAM) ;CHECK NAME FORMAT
+1 ;BAD
IF NAM?2.A.1(1" ",1"-").A1" "1(1"JR",1"SR",1"II",1"III",1"IV",1"V")1","2.A.1" ".A.1"."
QUIT -1
+2 ;GOOD
IF NAM?2.A.1(1" ",1"-").A1","1.A.1" ".A.1".".1",".3A.1"."
QUIT 1
+3 QUIT 0
+4 ;
BADADR ;EP
+1 ;----- FIND BAD ADDRESSES
+2 ;
+3 NEW BZXDT,BZXOUT,DIR,X,Y
+4 DO ^XBKVAR
+5 DO HOME^%ZIS
+6 ;
+7 WRITE !,"THIS REPORT PRINTS A LISTING OF BAD ADDRESSES IN THE VA PATIENT FILE"
+8 WRITE !
+9 ;
+10 SET BZXOUT=0
+11 DO CUTOFF(.BZXDT,.BZXOUT)
+12 IF BZXOUT
QUIT
+13 ;
+14 DO PRINTA(BZXDT)
+15 ;
+16 DO QUIT
+17 ;
+18 QUIT
PRINTA(BZXDT) ;
+1 ;
+2 NEW BZXTITLE,ZTDESC,ZTRTN,ZTSAVE
+3 ;
+4 SET BZXTITLE="BAD ADDRESS REPORT"
+5 SET ZTRTN="DQ1^BZXBPNA"
+6 SET ZTDESC=BZXTITLE
+7 SET ZTSAVE("BZXTITLE")=""
+8 SET ZTSAVE("BZXDT")=""
+9 DO QUE^BZXBPNA(ZTRTN,.ZTSAVE,ZTDESC)
+10 QUIT
DQ1 ;----- QUEUED JOB STARTS HERE
+1 ;
+2 NEW BZXDONE,BZXOUT,BZXPAGE,BZXVIEN,DFN
+3 ;
+4 SET (BZXOUT,BZXPAGE)=0
+5 DO HDR(.BZXPAGE,.BZXOUT,.BZXTITLE)
+6 IF BZXOUT
QUIT
+7 ;
+8 SET DFN=0
+9 FOR
SET DFN=$ORDER(^DPT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+10 SET BZXDONE=0
+11 SET BZXVIEN=0
+12 FOR
SET BZXVIEN=$ORDER(^AUPNVSIT("AC",DFN,BZXVIEN))
IF 'BZXVIEN
QUIT
Begin DoDot:2
+13 IF (+$GET(^AUPNVSIT(BZXVIEN,0)))<BZXDT
QUIT
+14 SET BZXDONE=1
+15 IF $Y>(IOSL-5)
DO HDR(.BZXPAGE,.BZXOUT,.BZXTITLE)
+16 IF BZXOUT
QUIT
+17 DO ONE(DFN)
End DoDot:2
IF BZXOUT
QUIT
IF BZXDONE
QUIT
End DoDot:1
IF BZXOUT
QUIT
+18 ;
+19 DO ^%ZISC
+20 QUIT
ONE(DFN) ;
+1 ;----- CHECK ONE DFN
+2 ;
+3 NEW BZXADDR,BZXADDR2,BZXADDR3,BZXCITY,BZXDATA,BZXGOOD,BZXNAME,BZXSSN,BZXSTATE,BZXZIP,IENS
+4 ;
+5 IF '$DATA(^DPT(DFN,0))
Begin DoDot:1
+6 WRITE !,"DFN #"_DFN_" IS MISSING A ZERO NODE"
End DoDot:1
QUIT
+7 ;
+8 ;START OUT AS A GOOD ONE
SET BZXGOOD=1
+9 SET IENS=DFN_","
+10 SET BZXADDR=$$GET1^DIQ(2,IENS,.111)
+11 IF BZXADDR']""
SET BZXADDR="<MISSING>"
SET BZXGOOD=0
+12 SET BZXGOOD=$$AD1CHK(BZXADDR)
+13 SET BZXDATA=$GET(^DPT(DFN,0))
+14 SET BZXNAME=$PIECE(BZXDATA,U)
+15 SET BZXSSN=$PIECE(BZXDATA,U,9)
+16 SET BZXDATA=$GET(^DPT(DFN,.11))
+17 SET BZXADDR2=$PIECE(BZXDATA,U,2)
+18 SET BZXADDR3=$PIECE(BZXDATA,U,3)
+19 SET BZXCITY=$PIECE(BZXDATA,U,4)
+20 IF BZXCITY']""
SET BZXCITY="<MISSING>"
SET BZXGOOD=0
+21 SET BZXSTATE=$$GET1^DIQ(2,IENS,.115)
+22 IF BZXSTATE']""
SET BZXSTATE="<MISSING>"
SET BZXGOOD=0
+23 SET BZXZIP=$PIECE(BZXDATA,U,6)
+24 IF BZXZIP']""
SET BZXZIP="<MISSING>"
SET BZXGOOD=0
+25 IF BZXGOOD
QUIT
+26 ;
+27 WRITE !,"("_DFN_")"
+28 WRITE ?12,BZXNAME,?37,BZXSSN
+29 WRITE !,BZXADDR
+30 IF BZXADDR2]""
WRITE !,BZXADDR2
+31 IF BZXADDR3]""
WRITE !,BZXADDR3
+32 WRITE !,BZXCITY_", "_BZXSTATE_" "_BZXZIP
+33 WRITE !
+34 QUIT
HDR(BZXPAGE,BZXOUT,BZXTITLE) ;
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,I,X,Y
+3 ;
+4 IF $EXTRACT(IOST)="C"
IF $GET(BZXPAGE)
Begin DoDot:1
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 IF 'Y
SET BZXOUT=1
End DoDot:1
+8 IF BZXOUT
QUIT
+9 SET BZXPAGE=$GET(BZXPAGE)+1
+10 WRITE @IOF
+11 WRITE !,BZXTITLE
+12 WRITE ?49,$$NOW
+13 WRITE " PAGE ",BZXPAGE
+14 WRITE !
+15 FOR I=1:1:IOM
WRITE "-"
+16 WRITE !!
+17 QUIT
QUE(ZTRTN,ZTSAVE,ZTDESC) ;
+1 ;----- QUEUEING CODE
+2 ;
+3 NEW %ZIS,IO,POP,ZTIO,ZTSK
+4 SET %ZIS="Q"
+5 DO ^%ZIS
+6 IF POP
QUIT
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 KILL IO("Q")
+9 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
+10 DO ^%ZTLOAD
+11 IF $GET(ZTSK)
WRITE !,"Task #",$GET(ZTSK)," queued"
End DoDot:1
QUIT
+12 DO @ZTRTN
+13 QUIT
CUTOFF(BZXDT,BZXOUT) ;
+1 ;----- RETURNS VISIT CUT OFF DATE
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="D^::EX"
+5 SET DIR("A")="Enter VISIT CUTOFF DATE"
+6 SET DIR("?")="The earliest VISIT DATE to include in the report"
+7 DO ^DIR
+8 IF +Y'>0
SET BZXOUT=1
+9 SET BZXDT=+Y
+10 QUIT
NOW() ;
+1 ;----- RETURNS CURRENT DATE/TIME
+2 ;
+3 NEW %,%H,%I,X,Y
+4 DO NOW^%DTC
+5 SET Y=DT
+6 XECUTE ^DD("DD")
+7 QUIT Y_" "_$EXTRACT($PIECE(%,".",2),1,2)_":"_$EXTRACT($PIECE(%,".",2),3,4)
+8 ;
AD1CHK(X) ;
+1 ;----- PATTERN MATCHES FOR ADDRESS LINE 1
+2 ;
+3 IF X?1.5N1" ".5AP.1" "3.NA.AP.N." "
QUIT 1
+4 IF X?1"P".1".".1" "1"O".1".".1" ".1"BOX"1" ".1"#"1.8N
QUIT 1
+5 QUIT 0
QUIT ;
+1 ;----- CLEAN UP, CLOSE DEVICE, QUIT JOB
+2 ;
+3 DO ^%ZISC
+4 QUIT
