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

BPMRP1.m

Go to the documentation of this file. 
  1. BPMRP1 ;IHS/PHXAO/AEF - BPM 1.0 P2 PRINT LIST OF PATIENTS MERGED - 6/26/12 ;
  1.  ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
  1.  ;IHS/OIT/LJF 11/15/2006 routine originated from Phoenix Area Office
  1.  ;                       changed namespace from BZXM to BPM
  1.  ;            11/16/2006 added DOB & SSN display for TO patient
  1.  ;IHS/OIT/NKD  6/13/2012 Corrected logic used to find the DPT node in ^XDRM
  1.  ;
  1. DESC ;----- ROUTINE DESCRIPTION
  1.  ;;
  1.  ;;BPMRP1
  1.  ;;THIS ROUTINE LOOPS THROUGH THE MERGE IMAGES FILE #15.4
  1.  ;;AND PRINTS A REPORT OF THOSE PATIENTS THAT HAVE BEEN MERGED
  1.  ;;SHOWING THE MERGE DATE, PATIENT NAME, DOB, AND SSN OF THE
  1.  ;;'MERGED FROM' PATIENT AND WHICH ENTRY IT WAS MERGED TO.
  1.  ;;
  1.  ;;$$END
  1.  ;
  1.  N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END"  D EN^DDIOL(X)
  1.  Q
  1. EN ;EP -- MAIN ENTRY POINT
  1.  ;
  1.  N ZTDESC,ZTRTN,ZTSAVE
  1.  ;
  1.  S ZTRTN="DQ^BPMRP1"
  1.  S ZTDESC="MERGED PATIENT LIST"
  1.  D QUE(ZTRTN,ZTDESC)
  1.  Q
  1. DQ ;EP -- QUEUED JOB STARTS HERE
  1.  ;
  1.  D ^XBKVAR
  1.  ;
  1.  K ^TMP("BPMRP1",$J)
  1.  D LOOP
  1.  D PRT
  1.  D ^%ZISC
  1.  Q
  1. LOOP ;----- MAIN LOOP THROUGH MERGE IMAGES FILE
  1.  ;
  1.  N BPMD0,BPMD1,BPMD2,BPMDATA,BPMDATE,BPMDOB,BPMFR,BPMFRN,BPMOUT,BPMSSN,BPMTO,BPMTON
  1.  ;
  1.  S BPMOUT=0
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^XDRM(BPMD0)) Q:'BPMD0  D
  1.  . S BPMDATA=$G(^XDRM(BPMD0,0))
  1.  . S BPMFR=+$P(BPMDATA,U)
  1.  . S BPMFRN=$P($G(^DPT(BPMFR,0)),U)
  1.  . S BPMTO=+$P(BPMDATA,U,2)
  1.  . S BPMTON=$P($G(^DPT(BPMTO,0)),U)
  1.  . S BPMDATE=$P(BPMDATA,U,3)
  1.  . I BPMDATE S BPMDATE=$$SLDATE(BPMDATE)
  1.  . S BPMD1=0
  1.  . F  S BPMD1=$O(^XDRM(BPMD0,1,BPMD1)) Q:'BPMD1  D  Q:BPMOUT
  1.  . . S BPMD2=0
  1.  . . F  S BPMD2=$O(^XDRM(BPMD0,1,BPMD1,1,BPMD2)) Q:'BPMD2  D  Q:BPMOUT
  1.  . . . ;IHS/OIT/NKD BPM*1.0*2 Corrected logic due to Cache resolving the expression as a number (instead of a string)
  1.  . . . ;I ^XDRM(BPMD0,1,BPMD1,1,BPMD2,0)="DPT("_BPMFR_",0)" D  Q:BPMOUT
  1.  . . . I ^XDRM(BPMD0,1,BPMD1,1,BPMD2,0)=("DPT("_BPMFR_",0)") D  Q:BPMOUT
  1.  . . . . S BPMOUT=1
  1.  . . . . ; get DOB and SSN for FROM patient
  1.  . . . . S BPMDATA=$G(^XDRM(BPMD0,1,BPMD1,1,BPMD2,1))
  1.  . . . . S BPMDOB=$P(BPMDATA,U,3)
  1.  . . . . I BPMDOB S BPMDOB=$$SLDATE(BPMDOB)
  1.  . . . . S BPMSSN=$P(BPMDATA,U,9)
  1.  . . . . S ^TMP("BPMRP1",$J,BPMFRN_";"_BPMFR)=BPMD0_U_BPMFR_U_BPMFRN_U_BPMDOB_U_BPMSSN_U_BPMTO_U_BPMTON_U_BPMDATE
  1.  . . . . ; now get DOB and SSN for TO patient;IHS/OIT/LJF 11/16/2006
  1.  . . . . S BPMDATA=$G(^XDRM(BPMD0,2,BPMD1,1,BPMD2,1))
  1.  . . . . S BPMDOB=$P(BPMDATA,U,3)
  1.  . . . . I BPMDOB S BPMDOB=$$SLDATE(BPMDOB)
  1.  . . . . S BPMSSN=$P(BPMDATA,U,9)
  1.  . . . . S $P(^TMP("BPMRP1",$J,BPMFRN_";"_BPMFR),U,9)=BPMDOB_U_BPMSSN
  1.  Q
  1. PRT ;----- PRINT THE ACTUAL REPORT
  1.  ;
  1.  N BPMOUT,BPMPAGE,BPMPAT,BPMX
  1.  ;
  1.  S BPMOUT=0
  1.  S BPMPAGE=0
  1.  ;
  1.  D HDR(.BPMPAGE,.BPMOUT)
  1.  Q:$G(BPMOUT)
  1.  ;
  1.  S BPMPAT=""
  1.  F  S BPMPAT=$O(^TMP("BPMRP1",$J,BPMPAT)) Q:BPMPAT']""  D  Q:BPMOUT
  1.  . I $Y>(IOSL-5) D HDR(.BPMPAGE,.BPMOUT)
  1.  . Q:$G(BPMOUT)
  1.  . I '$D(^TMP("BPMRP1",$J)) D  Q
  1.  . . W !!?5,"NO DATA TO PRINT"
  1.  . . S BPMOUT=1
  1.  . S BPMX=$G(^TMP("BPMRP1",$J,BPMPAT))
  1.  . W !?0,"FROM:"
  1.  . W ?7,$P(BPMX,U,2)
  1.  . W ?14,$P(BPMX,U,3)
  1.  . W ?46,$P(BPMX,U,4)
  1.  . W ?56,$P(BPMX,U,5)
  1.  . W ?67,$P(BPMX,U,8)
  1.  . W !?0,"  TO:"
  1.  . W ?7,$P(BPMX,U,6)
  1.  . W ?14,$P(BPMX,U,7)
  1.  . W ?46,$P(BPMX,U,9)
  1.  . W ?56,$P(BPMX,U,10)
  1.  . W !
  1.  ;
  1.  Q
  1. HDR(BPMPAGE,BPMOUT) ;
  1.  ;----- PRINT HEADER
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
  1.  ;
  1.  I $E(IOST)="C",$G(BPMPAGE) D
  1.  . S DIR(0)="E"
  1.  . D ^DIR
  1.  . K DIR
  1.  . I 'Y S BPMOUT=1
  1.  Q:BPMOUT
  1.  ;
  1.  S BPMPAGE=$G(BPMPAGE)+1
  1.  W @IOF
  1.  W !,"MERGED PATIENTS"
  1.  W ?49,$$NOW
  1.  W "   PAGE ",BPMPAGE
  1.  W !?7,"DFN",?14,"PATIENT NAME",?46,"DOB",?56,"SSN",?67,"DATE MERGED"
  1.  W !
  1.  F I=1:1:IOM W "-"
  1.  Q
  1. QUE(ZTRTN,ZTDESC) ;
  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. NOW()    ;EP -- RETURNS CURRENT DATE/TIME
  1.  ;
  1.  N %,%H,%I,X
  1.  D ^XBKVAR
  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. SLDATE(X) ;EP
  1.  ;----- RETURNS DATE IN MM/DD/YY FORMAT
  1.  ;
  1.  ;      X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X D
  1.  . Q:$L(X)'=7
  1.  . S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
  1.  Q Y