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

BZXBPNA.m

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