- 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