DPTDZPRE.m

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