DPTDZPRE ; IHS/TUCSON/JCM - PRE-MERGE INIT FOR PATIENT MERGE ; [ 09/10/2001 11:01 AM ]
;;1.0;PATIENT MERGE;;FEB 02, 1994
;IHS/ANMC/LJF 9/10/2001 made temp fix so HS and FS prints for TO pt
;
; The purpose of this routine is to do any pre-merge processing that
; needs to occur prior to the actual merging. At the present time
; the only thing that is occuring is the printing of the health
; summary and the face sheet.
;
; Input variables: XDRMRG("FR"),XDRMRG("TO")
;
; Calls: START^AGFACE,EN^APCHS
; Called by: XDRMRG
;--------------------------------------------------------------------
;
START ;
D CHECK
Q:$D(XDRM("AUTO"))
K DPTDZPRE
S DPTDZPRE("QFLG")=0
S DPTDZPRE("DFN")=$S($D(DFN):DFN,1:"")
D ASK G:DPTDZPRE("QFLG") END
S DPTDZPRE("FR")=XDRMRG("FR"),DPTDZPRE("TO")=XDRMRG("TO")
D DEVICE G:DPTDZPRE("QFLG") END
F DPTDZPRE=DPTDZPRE("FR"),DPTDZPRE("TO") S DPTDZPRE("PAT")=DPTDZPRE D:$D(DPTDZPRE("PCC")) HEALTH D FACE K AGOPT D:DPTDZPRE("PAT")'=DPTDZPRE("TO") DEVICE
END D EOJ
Q
;
ASK ;
K DIR
S DIR(0)="YO",DIR("B")="Y",DIR("A")="Do you wish to print a face sheet"
I $P(^AUTTSITE(1,0),U,8)="Y" S DIR("A")=DIR("A")_" and health summary" S DPTDZPRE("PCC")=""
D ^DIR K DIR
I $D(DUOUT)!($D(DTOUT)) S DPTDZPRE("QFLG")=1 G ASKX
I 'Y S DPTDZPRE("QFLG")=1 G ASKX
I $D(DPTDZPRE("PCC")) K DIC,Y S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQ" D
.S X=$S($D(^APCHSCTL("B","PATIENT MERGE (COMPLETE)")):"PATIENT MERGE (COMPLETE)",1:"ADULT REGULAR"),DIC("B")=X D ^DIC S:Y>0 DPTDZPRE("TYPE")=+Y S:Y'>0 DPTDZPRE("QFLG")=1 K DIC
ASKX K Y
Q
;
DEVICE ;
;S:$D(DPTDZPRE("DEVICE")) IOP=DPTDZPRE("DEVICE") ;IHS/ANMC/LJF 9/10/2001
S %ZIS(0)="MP" D ^%ZIS
I POP S DPTDZPRE("QFLG")=1 G DEVICEX
S DPTDZPRE("DEVICE")=$P(IO,";")_";"_IOST_";"_IOM_";"_IOSL
DEVICEX K %ZIS,POP
Q
;
HEALTH ;
I $D(^%ZOSF("XY"))#2 S (DX,DY)=0 X ^("XY") K DX,DY
K APCHSPAT,APCHSTYP
S APCHSPAT=DPTDZPRE("PAT"),APCHSTYP=DPTDZPRE("TYPE")
D EN^APCHS
Q
;
FACE ;
I $D(^%ZOSF("XY"))#2 S (DX,DY)=0 X ^("XY") K DX,DY
S DFN=DPTDZPRE("PAT")
D START^AGFACE K AGOPT
Q
;
CHECK ;
I $P(^DPT(XDRMRG("FR"),0),U,19)]""!($E($P(^DPT(XDRMRG("FR"),0),U),1)="*")!($E(^DPT(XDRMRG("TO"),0),1)="*")!($P(^DPT(XDRMRG("TO"),0),U,19)]"") D
.S XDRMRG("QFLG")=1
.Q:$D(ZTQUEUED)
.W !!,$C(7),"Either the FROM or the TO Patient has already been merged away!! You cannot ",!,"continue with this pair of patients. Jot down the following information and ",!,"give it to your supervisor and/or site manager.",!
.W !?5,"FROM Patient: ",$P(^DPT(XDRMRG("FR"),0),U,1),?40,"<DFN: ",XDRMRG("FR"),">"
.W !?5,"TO Patient: ",$P(^DPT(XDRMRG("TO"),0),U,1),?40,"<DFN: ",XDRMRG("TO"),">"
.W !?5,"DUPLICATE RECORD IEN: ",XDRMPDA,!
.Q
Q
EOJ ;
K:'DPTDZPRE("DFN") DFN S:DPTDZPRE("DFN") DFN=DPTDZPRE("DFN")
K DPTDZPRE
Q
DPTDZPRE ; IHS/TUCSON/JCM - PRE-MERGE INIT FOR PATIENT MERGE ; [ 09/10/2001 11:01 AM ]
+1 ;;1.0;PATIENT MERGE;;FEB 02, 1994
+2 ;IHS/ANMC/LJF 9/10/2001 made temp fix so HS and FS prints for TO pt
+3 ;
+4 ; The purpose of this routine is to do any pre-merge processing that
+5 ; needs to occur prior to the actual merging. At the present time
+6 ; the only thing that is occuring is the printing of the health
+7 ; summary and the face sheet.
+8 ;
+9 ; Input variables: XDRMRG("FR"),XDRMRG("TO")
+10 ;
+11 ; Calls: START^AGFACE,EN^APCHS
+12 ; Called by: XDRMRG
+13 ;--------------------------------------------------------------------
+14 ;
START ;
+1 DO CHECK
+2 IF $DATA(XDRM("AUTO"))
QUIT
+3 KILL DPTDZPRE
+4 SET DPTDZPRE("QFLG")=0
+5 SET DPTDZPRE("DFN")=$SELECT($DATA(DFN):DFN,1:"")
+6 DO ASK
IF DPTDZPRE("QFLG")
GOTO END
+7 SET DPTDZPRE("FR")=XDRMRG("FR")
SET DPTDZPRE("TO")=XDRMRG("TO")
+8 DO DEVICE
IF DPTDZPRE("QFLG")
GOTO END
+9 FOR DPTDZPRE=DPTDZPRE("FR"),DPTDZPRE("TO")
SET DPTDZPRE("PAT")=DPTDZPRE
IF $DATA(DPTDZPRE("PCC"))
DO HEALTH
DO FACE
KILL AGOPT
IF DPTDZPRE("PAT")'=DPTDZPRE("TO")
DO DEVICE
END DO EOJ
+1 QUIT
+2 ;
ASK ;
+1 KILL DIR
+2 SET DIR(0)="YO"
SET DIR("B")="Y"
SET DIR("A")="Do you wish to print a face sheet"
+3 IF $PIECE(^AUTTSITE(1,0),U,8)="Y"
SET DIR("A")=DIR("A")_" and health summary"
SET DPTDZPRE("PCC")=""
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)!($DATA(DTOUT))
SET DPTDZPRE("QFLG")=1
GOTO ASKX
+6 IF 'Y
SET DPTDZPRE("QFLG")=1
GOTO ASKX
+7 IF $DATA(DPTDZPRE("PCC"))
KILL DIC,Y
SET DIC=9001015
SET DIC("A")="Select health summary type: "
SET DIC(0)="AEQ"
Begin DoDot:1
+8 SET X=$SELECT($DATA(^APCHSCTL("B","PATIENT MERGE (COMPLETE)")):"PATIENT MERGE (COMPLETE)",1:"ADULT REGULAR")
SET DIC("B")=X
DO ^DIC
IF Y>0
SET DPTDZPRE("TYPE")=+Y
IF Y'>0
SET DPTDZPRE("QFLG")=1
KILL DIC
End DoDot:1
ASKX KILL Y
+1 QUIT
+2 ;
DEVICE ;
+1 ;S:$D(DPTDZPRE("DEVICE")) IOP=DPTDZPRE("DEVICE") ;IHS/ANMC/LJF 9/10/2001
+2 SET %ZIS(0)="MP"
DO ^%ZIS
+3 IF POP
SET DPTDZPRE("QFLG")=1
GOTO DEVICEX
+4 SET DPTDZPRE("DEVICE")=$PIECE(IO,";")_";"_IOST_";"_IOM_";"_IOSL
DEVICEX KILL %ZIS,POP
+1 QUIT
+2 ;
HEALTH ;
+1 IF $DATA(^%ZOSF("XY"))#2
SET (DX,DY)=0
XECUTE ^("XY")
KILL DX,DY
+2 KILL APCHSPAT,APCHSTYP
+3 SET APCHSPAT=DPTDZPRE("PAT")
SET APCHSTYP=DPTDZPRE("TYPE")
+4 DO EN^APCHS
+5 QUIT
+6 ;
FACE ;
+1 IF $DATA(^%ZOSF("XY"))#2
SET (DX,DY)=0
XECUTE ^("XY")
KILL DX,DY
+2 SET DFN=DPTDZPRE("PAT")
+3 DO START^AGFACE
KILL AGOPT
+4 QUIT
+5 ;
CHECK ;
+1 IF $PIECE(^DPT(XDRMRG("FR"),0),U,19)]""!($EXTRACT($PIECE(^DPT(XDRMRG("FR"),0),U),1)="*")!($EXTRACT(^DPT(XDRMRG("TO"),0),1)="*")!($PIECE(^DPT(XDRMRG("TO"),0),U,19)]"")
Begin DoDot:1
+2 SET XDRMRG("QFLG")=1
+3 IF $DATA(ZTQUEUED)
QUIT
+4 WRITE !!,$CHAR(7),"Either the FROM or the TO Patient has already been merged away!! You cannot ",!,"continue with this pair of patients. Jot down the following information and ",!,"give it to your supervisor and/or site manager.",!
+5 WRITE !?5,"FROM Patient: ",$PIECE(^DPT(XDRMRG("FR"),0),U,1),?40,"<DFN: ",XDRMRG("FR"),">"
+6 WRITE !?5,"TO Patient: ",$PIECE(^DPT(XDRMRG("TO"),0),U,1),?40,"<DFN: ",XDRMRG("TO"),">"
+7 WRITE !?5,"DUPLICATE RECORD IEN: ",XDRMPDA,!
+8 QUIT
End DoDot:1
+9 QUIT
EOJ ;
+1 IF 'DPTDZPRE("DFN")
KILL DFN
IF DPTDZPRE("DFN")
SET DFN=DPTDZPRE("DFN")
+2 KILL DPTDZPRE
+3 QUIT
