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