DPTDZPO ; IHS/TUCSON/JCM - IHS PATIENT POST-MERGE ROUTINE ; [ 02/03/94 7:29 AM ]
;;1.0;PATIENT MERGE;;FEB 02, 1994
;
; Calls: DIC,DIE,DIK
;
START ;
D INIT
D AGPATCH
D RESET
D:'$D(XDRM("AUTO")) ^DPTDZPO1
END D EOJ
Q
;
INIT ;
K DPTDZPO
S DPTDZPO("FR NAME")=$P(^DPT(XDRMRG("FR"),0),U)
S DPTDZPO("ORIG TO NAME")=$P(^TMP("XDRMRGTO",$J,XDRMRG("TO"),0),U)
I DPTDZPO("ORIG TO NAME")'=$P(^DPT(XDRMRG("TO"),0),U) D OTHER
F DPTDZPO("CH")=0:0 S DPTDZPO("CH")=$O(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("CH"))) Q:'DPTDZPO("CH") D
. I $P(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("CH"),0),U,2)]"" S DPTDZPO("CN",DPTDZPO("CH"))=$P(^(0),U,2)
. I '$D(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("CH"),0)) K DPTDZPO("CN",DPTDZPO("CH")) Q
. I $D(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("CH"),0)),$P(^(0),U,2)]"",$P(^(0),U,2)=DPTDZPO("CN",DPTDZPO("CH")) K DPTDZPO("CN",DPTDZPO("CH"))
. Q
Q
;
OTHER ;
S DIC="^DPT("_XDRMRG("TO")_",.01,",DIC(0)="FL"
S DIC("P")=$P(^DD(2,1,0),U,2),DA(1)=XDRMRG("TO"),X=DPTDZPO("ORIG TO NAME")
D ^DIC K DA,DIC,DIE
Q
;
AGPATCH ; Sets up AGPATCH global for transmission
I $D(^APMF(96.01,1,0)),$P(^(0),U,4) G AGPATCHX
S DPTDZPO("TDUZ2")=$S($O(^AUPNPAT(XDRMRG("TO"),41,DUZ(2),"")):DUZ(2),1:$O(^AUPNPAT(XDRMRG("TO"),41,0))) G:'DPTDZPO("TDUZ2") AGPATCHX
S DPTDZPO("FDUZ2")=$S($O(^AUPNPAT(XDRMRG("FR"),41,DUZ(2),"")):DUZ(2),1:$O(^AUPNPAT(XDRMRG("FR"),41,0))) G:'DPTDZPO("FDUZ2") AGPATCHT
S DPTDZPO("P6")=DPTDZPO("TDUZ2")
S DPTDZPO("P3")=$S(DPTDZPO("P6")]"":$P(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("P6"),0),U,2),1:"")
S DPTDZPO("P4")=$P(^DPT(XDRMRG("TO"),0),U,1),DPTDZPO("P4")=$E(DPTDZPO("P4"),1)_$E($P(DPTDZPO("P4"),",",2),1)
S DPTDZPO("P5")=$P(^DPT(XDRMRG("TO"),0),U,2)
S DPTDZPO("P2")=$P(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("FDUZ2"),0),U,2)
I DPTDZPO("TDUZ2")=DPTDZPO("FDUZ2"),DPTDZPO("P3")=DPTDZPO("P2") G AGPATCHT
I DPTDZPO("P2")'?1.6N G AGPATCHT
I DPTDZPO("P3")'?1.6N G AGPATCHT
S ^AGPATCH(DT,DPTDZPO("FDUZ2"),XDRMRG("FR"))=DPTDZPO("FDUZ2")_"^"_$P(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("FDUZ2"),0),U,2)_"^"_DPTDZPO("P3")_U_DPTDZPO("P4")_U_DPTDZPO("P5")_U_DPTDZPO("P6")
AGPATCHT S ^AGPATCH(DT,DPTDZPO("TDUZ2"),XDRMRG("TO"))=""
AGPATCHX Q
;
RESET ;
S DIK="^AUPNPAT(",DA=XDRMRG("FR") D ^DIK K DA,DIK
S ^AUPNPAT(XDRMRG("FR"),0)=XDRMRG("FR")
S ^AUPNPAT("B",XDRMRG("FR"),XDRMRG("FR"))=""
L +^AUPNPAT(0):0 S $P(^(0),U,4)=($P(^AUPNPAT(0),U,4)+1) L -^AUPNPAT(0):0
F DPTDZPO("CH")=0:0 S DPTDZPO("CH")=$O(DPTDZPO("CN",DPTDZPO("CH"))) Q:'DPTDZPO("CH") D
. S DIC="^AUPNPAT("_XDRMRG("FR")_",41,",DIC(0)="FL",DIC("P")=$P(^DD(9000001,4101,0),U,2),DIC("DR")=".02////"_DPTDZPO("CN",DPTDZPO("CH"))_";.05////M",DA(1)=XDRMRG("FR"),X="`"_DPTDZPO("CH")
. D ^DIC K DA,DIC,DIE,DR
. Q
S DIK="^DPT(",DA=XDRMRG("FR") D ^DIK K DA,DIK
S ^DPT(XDRMRG("FR"),0)="*"_$E(DPTDZPO("FR NAME"),1,28)_"*",$P(^(0),U,19)=XDRMRG("TO")
S ^DPT("B","*"_$E(DPTDZPO("FR NAME"),1,28)_"*",XDRMRG("FR"))=""
L +^DPT(0):0 S $P(^(0),U,4)=($P(^DPT(0),U,4)+1) L -^DPT(0):0
S DIE="^AUPNPAT(",DA=XDRMRG("TO"),DR=".03////"_DT_";.12////"_DUZ_";.16////"_DT
D ^DIE K DIE,DIC,DR,DA
Q
;
EOJ ;
K DPTDZPO
Q
DPTDZPO ; IHS/TUCSON/JCM - IHS PATIENT POST-MERGE ROUTINE ; [ 02/03/94 7:29 AM ]
+1 ;;1.0;PATIENT MERGE;;FEB 02, 1994
+2 ;
+3 ; Calls: DIC,DIE,DIK
+4 ;
START ;
+1 DO INIT
+2 DO AGPATCH
+3 DO RESET
+4 IF '$DATA(XDRM("AUTO"))
DO ^DPTDZPO1
END DO EOJ
+1 QUIT
+2 ;
INIT ;
+1 KILL DPTDZPO
+2 SET DPTDZPO("FR NAME")=$PIECE(^DPT(XDRMRG("FR"),0),U)
+3 SET DPTDZPO("ORIG TO NAME")=$PIECE(^TMP("XDRMRGTO",$JOB,XDRMRG("TO"),0),U)
+4 IF DPTDZPO("ORIG TO NAME")'=$PIECE(^DPT(XDRMRG("TO"),0),U)
DO OTHER
+5 FOR DPTDZPO("CH")=0:0
SET DPTDZPO("CH")=$ORDER(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("CH")))
IF 'DPTDZPO("CH")
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("CH"),0),U,2)]""
SET DPTDZPO("CN",DPTDZPO("CH"))=$PIECE(^(0),U,2)
+7 IF '$DATA(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("CH"),0))
KILL DPTDZPO("CN",DPTDZPO("CH"))
QUIT
+8 IF $DATA(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("CH"),0))
IF $PIECE(^(0),U,2)]""
IF $PIECE(^(0),U,2)=DPTDZPO("CN",DPTDZPO("CH"))
KILL DPTDZPO("CN",DPTDZPO("CH"))
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
OTHER ;
+1 SET DIC="^DPT("_XDRMRG("TO")_",.01,"
SET DIC(0)="FL"
+2 SET DIC("P")=$PIECE(^DD(2,1,0),U,2)
SET DA(1)=XDRMRG("TO")
SET X=DPTDZPO("ORIG TO NAME")
+3 DO ^DIC
KILL DA,DIC,DIE
+4 QUIT
+5 ;
AGPATCH ; Sets up AGPATCH global for transmission
+1 IF $DATA(^APMF(96.01,1,0))
IF $PIECE(^(0),U,4)
GOTO AGPATCHX
+2 SET DPTDZPO("TDUZ2")=$SELECT($ORDER(^AUPNPAT(XDRMRG("TO"),41,DUZ(2),"")):DUZ(2),1:$ORDER(^AUPNPAT(XDRMRG("TO"),41,0)))
IF 'DPTDZPO("TDUZ2")
GOTO AGPATCHX
+3 SET DPTDZPO("FDUZ2")=$SELECT($ORDER(^AUPNPAT(XDRMRG("FR"),41,DUZ(2),"")):DUZ(2),1:$ORDER(^AUPNPAT(XDRMRG("FR"),41,0)))
IF 'DPTDZPO("FDUZ2")
GOTO AGPATCHT
+4 SET DPTDZPO("P6")=DPTDZPO("TDUZ2")
+5 SET DPTDZPO("P3")=$SELECT(DPTDZPO("P6")]"":$PIECE(^AUPNPAT(XDRMRG("TO"),41,DPTDZPO("P6"),0),U,2),1:"")
+6 SET DPTDZPO("P4")=$PIECE(^DPT(XDRMRG("TO"),0),U,1)
SET DPTDZPO("P4")=$EXTRACT(DPTDZPO("P4"),1)_$EXTRACT($PIECE(DPTDZPO("P4"),",",2),1)
+7 SET DPTDZPO("P5")=$PIECE(^DPT(XDRMRG("TO"),0),U,2)
+8 SET DPTDZPO("P2")=$PIECE(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("FDUZ2"),0),U,2)
+9 IF DPTDZPO("TDUZ2")=DPTDZPO("FDUZ2")
IF DPTDZPO("P3")=DPTDZPO("P2")
GOTO AGPATCHT
+10 IF DPTDZPO("P2")'?1.6N
GOTO AGPATCHT
+11 IF DPTDZPO("P3")'?1.6N
GOTO AGPATCHT
+12 SET ^AGPATCH(DT,DPTDZPO("FDUZ2"),XDRMRG("FR"))=DPTDZPO("FDUZ2")_"^"_$PIECE(^AUPNPAT(XDRMRG("FR"),41,DPTDZPO("FDUZ2"),0),U,2)_"^"_DPTDZPO("P3")_U_DPTDZPO("P4")_U_DPTDZPO("P5")_U_DPTDZPO("P6")
AGPATCHT SET ^AGPATCH(DT,DPTDZPO("TDUZ2"),XDRMRG("TO"))=""
AGPATCHX QUIT
+1 ;
RESET ;
+1 SET DIK="^AUPNPAT("
SET DA=XDRMRG("FR")
DO ^DIK
KILL DA,DIK
+2 SET ^AUPNPAT(XDRMRG("FR"),0)=XDRMRG("FR")
+3 SET ^AUPNPAT("B",XDRMRG("FR"),XDRMRG("FR"))=""
+4 LOCK +^AUPNPAT(0):0
SET $PIECE(^(0),U,4)=($PIECE(^AUPNPAT(0),U,4)+1)
LOCK -^AUPNPAT(0):0
+5 FOR DPTDZPO("CH")=0:0
SET DPTDZPO("CH")=$ORDER(DPTDZPO("CN",DPTDZPO("CH")))
IF 'DPTDZPO("CH")
QUIT
Begin DoDot:1
+6 SET DIC="^AUPNPAT("_XDRMRG("FR")_",41,"
SET DIC(0)="FL"
SET DIC("P")=$PIECE(^DD(9000001,4101,0),U,2)
SET DIC("DR")=".02////"_DPTDZPO("CN",DPTDZPO("CH"))_";.05////M"
SET DA(1)=XDRMRG("FR")
SET X="`"_DPTDZPO("CH")
+7 DO ^DIC
KILL DA,DIC,DIE,DR
+8 QUIT
End DoDot:1
+9 SET DIK="^DPT("
SET DA=XDRMRG("FR")
DO ^DIK
KILL DA,DIK
+10 SET ^DPT(XDRMRG("FR"),0)="*"_$EXTRACT(DPTDZPO("FR NAME"),1,28)_"*"
SET $PIECE(^(0),U,19)=XDRMRG("TO")
+11 SET ^DPT("B","*"_$EXTRACT(DPTDZPO("FR NAME"),1,28)_"*",XDRMRG("FR"))=""
+12 LOCK +^DPT(0):0
SET $PIECE(^(0),U,4)=($PIECE(^DPT(0),U,4)+1)
LOCK -^DPT(0):0
+13 SET DIE="^AUPNPAT("
SET DA=XDRMRG("TO")
SET DR=".03////"_DT_";.12////"_DUZ_";.16////"_DT
+14 DO ^DIE
KILL DIE,DIC,DR,DA
+15 QUIT
+16 ;
EOJ ;
+1 KILL DPTDZPO
+2 QUIT
