- AGUPCHK ; IHS/ASDS/EFG - Merge Insurer Data ;
- ;;7.1;PATIENT REGISTRATION;**12**;AUG 25,2005;Build 1
- ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
- ;
- S U="^"
- D HD
- W !!,"This routine will loop the old or unverified Insurers allowing you to check",!,"for a potential duplicate."
- W !!," - If you indicate that an insurer is duplicate that the data for the ",!," duplicate insurer will be merged into the old insurer (previous address",!," information will be transfered to the billing address fields)."
- W !! K DIR S DIR(0)="Y",DIR("A")="Do you wish to run this program",DIR("B")="Y" D ^DIR K DIR I Y'=1 G XIT
- S AG("MODE")="AUTO"
- TEMP S (AG("Y"),AG("XIT"))=0 F AGZ("I")=1:1 S AG("Y")=$O(^AUTNINS(AG("Y"))) Q:'+AG("Y") I $P($G(^AUTNINS(AG("Y"),1)),U,7)=""!($P($G(^(1)),U,7)=3) S AG("X0")=^(0) D CHK Q:AG("XIT")
- G XIT
- SEL D HD W !
- S AG("MODE")="SEL"
- ;S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)"
- S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)" ;IHS/OIT/NKD AG*7.1*12
- D ^DIC
- I X="" G XIT
- I +Y<1 G SEL
- S AG("Y")=+Y,AG("X0")=^AUTNINS(+Y,0)
- D CHK
- G XIT:AG("XIT"),SEL
- CHK W !!,"Dup-Check for: ",$P(AG("X0"),U),!?15,$P(AG("X0"),U,2)
- I $P(AG("X0"),U,3)]"",$P(AG("X0"),U,4)]"" W !?15,$P(AG("X0"),U,3),", "
- I W $P(^DIC(5,$P(AG("X0"),U,4),0),U,2)," ",$P(AG("X0"),U,5)
- W !,"================================================"
- ;S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC
- S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC ;IHS/OIT/NKD AG*7.1*12
- I +Y<1 G CONT
- S AG=+Y,AG("Y0")=^AUTNINS(+Y,0)
- W !,"_______________________________________________________________________________"
- W !,"[1] ",$P(AG("X0"),U),?39,"| [2] ",$P(Y,U,2)
- W !," ",$P(AG("X0"),U,2),?39,"| ",$P(AG("Y0"),U,2)
- W ! I $P(AG("X0"),U,3)]"",$P(AG("X0"),U,4)]"" W " ",$P(AG("X0"),U,3),", "
- I W $P(^DIC(5,$P(AG("X0"),U,4),0),U,2)," ",$P(AG("X0"),U,5)
- W ?39,"| " I $P(AG("Y0"),U,3)]"",$P(^(0),U,4)]"" W $P(^(0),U,3),", ",$P(^DIC(5,$P(^(0),U,4),0),U,2)," ",$P(^AUTNINS(+Y,0),U,5)
- W !,"-------------------------------------------------------------------------------"
- W ! K DIR S DIR(0)="Y",DIR("A")=" Are the two Insurers duplicates (Y/N)" D ^DIR K DIR I Y'=1 G CONT
- W !,"OK, MERGING.."
- D MOVE G VERF
- CONT W !! K DIR S DIR(0)="Y",DIR("A")="Do you want to dup-check "_$P(AG("X0"),U)_" any more",DIR("B")="Y" D ^DIR K DIR I Y=1 G CHK
- VERF S DIE="^AUTNINS(",DA=AG("Y"),DR=".17//1;.41//"_$P(AG("Y0"),U) D ^DIE
- W !! K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue running this program",DIR("B")="Y" D ^DIR K DIR I Y'=1 S AG("XIT")=1
- Q
- MOVE K AG("ADD")
- I $D(^AUTNINS(AG("Y"),1)),$P(^(1),U)]"",$P(^(1),U,2)]"",$P(^(1),U,3)]"",$P(^(1),U,4)]"",$P(^(1),U,5)]"" G MV1
- I $P(^AUTNINS(AG("Y"),0),U,2)]"",$P(^(0),U,3)]"",$P(^(0),U,4)]"",$P(^(0),U,5)]"" F AG("I")=1:1:5 S AG("ADD",AG("I"))=$P(^(0),U,AG("I"))
- MV1 S AG("B")="^AUTNINS("_AG("Y")_","
- S AG("A")="^AUTNINS("_AG,AG("A1")=AG("A")_")"
- F AGZ("I")=1:1 S AG("A1")=$Q(@AG("A1")) Q:AG("A1")'[AG("A") S AG("Z")=AG("B")_$P($P(AG("A1"),"(",2),",",2,99) D
- .S AG("C")=$P($P(AG("A1"),"(",2),",",2,99)
- .S @AG("Z")=@AG("A1")
- I $D(AG("ADD")) F AG("I")=1:1:5 Q:'$D(AG("ADD",AG("I"))) S $P(^AUTNINS(AG("Y"),1),U,AG("I"))=AG("ADD",AG("I"))
- S DA=AG("Y"),DIK="^AUTNINS(" D IX1^DIK
- S DIK="^AUTNINS(",DA=AG D ^DIK
- W !!,"Re-directing Pointers..."
- S DA(1)="" F AGZ("I")=1:1 S DA(1)=$O(^AUPNPRVT("I",AG,DA(1))) Q:'+DA(1) D
- .S DA="" F AGZ("I")=1:1 S DA=$O(^AUPNPRVT("I",AG,DA(1),DA)) Q:'+DA S DIE="^AUPNPRVT("_DA(1)_",11,",DR=".01///"_AG("Y") D ^DIE
- S DA="" F AGZ("I")=1:1 S DA=$O(^AUPN3PPH("E",AG,DA)) Q:'+DA S DIE="^AUPN3PPH(",DR=".03////"_AG("Y") D ^DIE
- S DA="" F AGZ("I")=1:1 S DA=$O(^AUTTPIC("C",AG,DA)) Q:'+DA S DIE="^AUTTPIC(",DR=".02////"_AG("Y") D ^DIE
- Q
- HD W $$S^AGVDF("IOF")
- W !?15,"*******************************************"
- W !?15,"* INSURER DUPLICATE CHECKER *"
- W !?15,"*******************************************"
- Q
- XIT K AG
- Q
- AGUPCHK ; IHS/ASDS/EFG - Merge Insurer Data ;
- +1 ;;7.1;PATIENT REGISTRATION;**12**;AUG 25,2005;Build 1
- +2 ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
- +3 ;
- +4 SET U="^"
- +5 DO HD
- +6 WRITE !!,"This routine will loop the old or unverified Insurers allowing you to check",!,"for a potential duplicate."
- +7 WRITE !!," - If you indicate that an insurer is duplicate that the data for the ",!," duplicate insurer will be merged into the old insurer (previous address",!," information will be transfered to the billing address fields)."
- +8 WRITE !!
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish to run this program"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- IF Y'=1
- GOTO XIT
- +9 SET AG("MODE")="AUTO"
- TEMP SET (AG("Y"),AG("XIT"))=0
- FOR AGZ("I")=1:1
- SET AG("Y")=$ORDER(^AUTNINS(AG("Y")))
- IF '+AG("Y")
- QUIT
- IF $PIECE($GET(^AUTNINS(AG("Y"),1)),U,7)=""!($PIECE($GET(^(1)),U,7)=3)
- SET AG("X0")=^(0)
- DO CHK
- IF AG("XIT")
- QUIT
- +1 GOTO XIT
- SEL DO HD
- WRITE !
- +1 SET AG("MODE")="SEL"
- +2 ;S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)"
- +3 ;IHS/OIT/NKD AG*7.1*12
- SET AG("XIT")=0
- SET DIC="^AUTNINS("
- SET DIC(0)="QEAM"
- SET DIC("A")="Select INSURER (to Search against): "
- SET DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)"
- +4 DO ^DIC
- +5 IF X=""
- GOTO XIT
- +6 IF +Y<1
- GOTO SEL
- +7 SET AG("Y")=+Y
- SET AG("X0")=^AUTNINS(+Y,0)
- +8 DO CHK
- +9 IF AG("XIT")
- GOTO XIT
- GOTO SEL
- CHK WRITE !!,"Dup-Check for: ",$PIECE(AG("X0"),U),!?15,$PIECE(AG("X0"),U,2)
- +1 IF $PIECE(AG("X0"),U,3)]""
- IF $PIECE(AG("X0"),U,4)]""
- WRITE !?15,$PIECE(AG("X0"),U,3),", "
- +2 IF $TEST
- WRITE $PIECE(^DIC(5,$PIECE(AG("X0"),U,4),0),U,2)," ",$PIECE(AG("X0"),U,5)
- +3 WRITE !,"================================================"
- +4 ;S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC
- +5 ;IHS/OIT/NKD AG*7.1*12
- SET DIC="^AUTNINS("
- SET DIC(0)="QEAM"
- SET DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)"
- SET DIC("A")="Select (SEARCH) for Duplicate INSURER: "
- DO ^DIC
- +6 IF +Y<1
- GOTO CONT
- +7 SET AG=+Y
- SET AG("Y0")=^AUTNINS(+Y,0)
- +8 WRITE !,"_______________________________________________________________________________"
- +9 WRITE !,"[1] ",$PIECE(AG("X0"),U),?39,"| [2] ",$PIECE(Y,U,2)
- +10 WRITE !," ",$PIECE(AG("X0"),U,2),?39,"| ",$PIECE(AG("Y0"),U,2)
- +11 WRITE !
- IF $PIECE(AG("X0"),U,3)]""
- IF $PIECE(AG("X0"),U,4)]""
- WRITE " ",$PIECE(AG("X0"),U,3),", "
- +12 IF $TEST
- WRITE $PIECE(^DIC(5,$PIECE(AG("X0"),U,4),0),U,2)," ",$PIECE(AG("X0"),U,5)
- +13 WRITE ?39,"| "
- IF $PIECE(AG("Y0"),U,3)]""
- IF $PIECE(^(0),U,4)]""
- WRITE $PIECE(^(0),U,3),", ",$PIECE(^DIC(5,$PIECE(^(0),U,4),0),U,2)," ",$PIECE(^AUTNINS(+Y,0),U,5)
- +14 WRITE !,"-------------------------------------------------------------------------------"
- +15 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")=" Are the two Insurers duplicates (Y/N)"
- DO ^DIR
- KILL DIR
- IF Y'=1
- GOTO CONT
- +16 WRITE !,"OK, MERGING.."
- +17 DO MOVE
- GOTO VERF
- CONT WRITE !!
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to dup-check "_$PIECE(AG("X0"),U)_" any more"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- IF Y=1
- GOTO CHK
- VERF SET DIE="^AUTNINS("
- SET DA=AG("Y")
- SET DR=".17//1;.41//"_$PIECE(AG("Y0"),U)
- DO ^DIE
- +1 WRITE !!
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish to continue running this program"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- IF Y'=1
- SET AG("XIT")=1
- +2 QUIT
- MOVE KILL AG("ADD")
- +1 IF $DATA(^AUTNINS(AG("Y"),1))
- IF $PIECE(^(1),U)]""
- IF $PIECE(^(1),U,2)]""
- IF $PIECE(^(1),U,3)]""
- IF $PIECE(^(1),U,4)]""
- IF $PIECE(^(1),U,5)]""
- GOTO MV1
- +2 IF $PIECE(^AUTNINS(AG("Y"),0),U,2)]""
- IF $PIECE(^(0),U,3)]""
- IF $PIECE(^(0),U,4)]""
- IF $PIECE(^(0),U,5)]""
- FOR AG("I")=1:1:5
- SET AG("ADD",AG("I"))=$PIECE(^(0),U,AG("I"))
- MV1 SET AG("B")="^AUTNINS("_AG("Y")_","
- +1 SET AG("A")="^AUTNINS("_AG
- SET AG("A1")=AG("A")_")"
- +2 FOR AGZ("I")=1:1
- SET AG("A1")=$QUERY(@AG("A1"))
- IF AG("A1")'[AG("A")
- QUIT
- SET AG("Z")=AG("B")_$PIECE($PIECE(AG("A1"),"(",2),",",2,99)
- Begin DoDot:1
- +3 SET AG("C")=$PIECE($PIECE(AG("A1"),"(",2),",",2,99)
- +4 SET @AG("Z")=@AG("A1")
- End DoDot:1
- +5 IF $DATA(AG("ADD"))
- FOR AG("I")=1:1:5
- IF '$DATA(AG("ADD",AG("I")))
- QUIT
- SET $PIECE(^AUTNINS(AG("Y"),1),U,AG("I"))=AG("ADD",AG("I"))
- +6 SET DA=AG("Y")
- SET DIK="^AUTNINS("
- DO IX1^DIK
- +7 SET DIK="^AUTNINS("
- SET DA=AG
- DO ^DIK
- +8 WRITE !!,"Re-directing Pointers..."
- +9 SET DA(1)=""
- FOR AGZ("I")=1:1
- SET DA(1)=$ORDER(^AUPNPRVT("I",AG,DA(1)))
- IF '+DA(1)
- QUIT
- Begin DoDot:1
- +10 SET DA=""
- FOR AGZ("I")=1:1
- SET DA=$ORDER(^AUPNPRVT("I",AG,DA(1),DA))
- IF '+DA
- QUIT
- SET DIE="^AUPNPRVT("_DA(1)_",11,"
- SET DR=".01///"_AG("Y")
- DO ^DIE
- End DoDot:1
- +11 SET DA=""
- FOR AGZ("I")=1:1
- SET DA=$ORDER(^AUPN3PPH("E",AG,DA))
- IF '+DA
- QUIT
- SET DIE="^AUPN3PPH("
- SET DR=".03////"_AG("Y")
- DO ^DIE
- +12 SET DA=""
- FOR AGZ("I")=1:1
- SET DA=$ORDER(^AUTTPIC("C",AG,DA))
- IF '+DA
- QUIT
- SET DIE="^AUTTPIC("
- SET DR=".02////"_AG("Y")
- DO ^DIE
- +13 QUIT
- HD WRITE $$S^AGVDF("IOF")
- +1 WRITE !?15,"*******************************************"
- +2 WRITE !?15,"* INSURER DUPLICATE CHECKER *"
- +3 WRITE !?15,"*******************************************"
- +4 QUIT
- XIT KILL AG
- +1 QUIT
