IB20R244 ;ISP/TDP - Restoral routine for IB*2.0*244 ;10/14/2003
;;2.0;INTEGRATED BILLING;**244**;21-MAR-94
; This routine is to restore data to the SUBSCRIBER ID (#1) field
; of the INSURANCE TYPE SUB-FIELD (#2.312) file of the PATIENT (#2)
; file and to the IB DM EXTRACT DATA (#351.71) file that was removed
; during the data conversion by post-init routine IB20P244 in patch
; IB*2.0*244. Data can only be restored if the ^XTMP("IB20P244" file
; still exists.
Q
UNDOALL ;Undoes all the changes made by the post-init routine, based on what
;is stored in ^XTMP("IB20P244".
N ALL,IBDIK
S ALL=1,IBDIK=0
I '$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
D UNDOP
D UNDOF
D UNDOSUB
W !!,"Data restoral complete."
Q
UNDOP ;Restore the past date entries in file 351.71 which were deleted.
N IBJ,PCNT,PDATE
I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
S PCNT=0
S IBJ=""
F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
. S PDATE=""
. F S PDATE=$O(^XTMP("IB20P244",IBJ,"INS","PST",PDATE)) Q:PDATE="" D
.. S PCNT=PCNT+1
.. D MDATE(PDATE,"PST","RSTP")
W !
I PCNT=0 W !,"There are no past date entries to restore for file 351.71."
I PCNT'=0 S IBDIK=1 I '$G(ALL) D RENDX K IBDIK
Q
UNDOF ;Restore the future date entries in file 351.71 which were deleted.
N IBJ,FCNT,FDATE
I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
S FCNT=0
S IBJ=""
F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
. S FDATE=""
. F S FDATE=$O(^XTMP("IB20P244",IBJ,"INS","FUT",FDATE)) Q:FDATE="" D
.. S FCNT=FCNT+1
.. D MDATE(FDATE,"FUT","RSTF")
W !
I FCNT=0 W !,"There are no future date entries to restore for file 351.71."
I FCNT'=0!($G(IBDIK)) D RENDX
Q
RENDX ;Re-index file 351.71.
W !!,"Re-indexing file 351.71..."
S DIK="^IBE(351.71," D IXALL^DIK K DIK
W "Done"
Q
MDATE(DATE,DTYP,DRTYP) ;Common date functionality merge/kill
I $O(^IBE(351.71,DATE,""))'="" W !,"Entry already exists for "_DATE_". Skipping restoral of this date entry." Q
M ^IBE(351.71,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
M ^XTMP("IB20P244",IBJ,"INS",DRTYP,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
K ^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
W !,"The entry for "_DATE_" has been restored."
Q
UNDOSUB ;Restore original SUBSCRIBER ID'S modified in the INSURANCE TYPE
;SUB-FIELD (#2.312) file of the PATIENT (#2) file.
N DA,DFN,DIE,DR,IBDATE,IBINS,IBINSCO,IBINSNM,IBJ,IBJN,IBNAME,IBNODATA
N IBSSN,IBSUB,IBSUB1,SCNT,SEL,X,Y
I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
I $G(ALL) W ! G ALL
CHOICE S DIR("A")="DO YOU WANT TO RESTORE (A)LL OR (S)ELECTED SUBSCRIBER ID'S? "
S DIR("B")="QUIT"
S DIR("T")=300
S DIR("?")="Choose ALL to restore all subscriber id's, or choose SELECTED to choose individual patient's for restoral."
S DIR(0)="FAO^1:8^"
D ^DIR
I $E(X,1)="S" S Y="SELECTED"
I $E(X,1)="A" S Y="ALL"
I Y="QUIT"!(Y="")!($D(DTOUT))!($D(DUOUT)) G SUBEXIT
I Y'="ALL",Y'="SELECTED" G CHOICE
I Y="ALL" W ! G ALL
CHOICE1 S DIR("A")="DO YOU WANT TO RESTORE BY (P)ATIENT OR BY (I)NSURANCE COMPANY? "
S DIR("B")="QUIT"
S DIR("T")=300
S DIR("?")="Choose PATIENT to restore specific patient subscriber id's, or choose INSURANCE COMPANY to choose specific insurance companies for restoral."
S DIR(0)="FAO^1:8^"
D ^DIR
S IBNODATA=0
I $E(X,1)="P" S Y="PATIENT"
I $E(X,1)="I" S Y="INSURANCE COMPANY"
I Y="QUIT"!(Y="")!($D(DTOUT))!($D(DUOUT)) G CHOICE
I Y'="PATIENT",Y'="INSURANCE COMPANY" G CHOICE1
I Y="PATIENT" W ! S SEL="PAT" G SELPAT
W !
S SEL="INS"
SELINS D GATHER I IBNODATA Q
SELECT1 S DIC("A")="SELECT INSURANCE COMPANY TO RESTORE SUBSCRIBER ID'S FOR: "
S DIC(0)="AENQ"
S DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
S DIC="^DIC(36,"
D ^DIC
I $D(DTOUT)!($D(DUOUT))!((X="")&('$D(^TMP("IB20P244",$J,"SEL")))) G CHOICE1
I X="" W ! G SEL1
S IBINS=$P($G(Y),U,1)
M ^TMP("IB20P244",$J,"SEL",IBINS)=^TMP("IB20P244",$J,"SUB",IBINS)
S (X,Y)="" G SELECT1
SEL1 ;RESTORE SELECTED INSURANCE COMPANY SUBSCRIBER ID'S
S IBINSCO=""
F S IBINSCO=$O(^TMP("IB20P244",$J,"SEL",IBINSCO)) Q:IBINSCO="" D
. S IBINSNM=$P($G(^DIC(36,IBINSCO,0)),U,1)
. S IBJ=""
. F S IBJ=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ)) Q:IBJ="" D
.. S IBJN=-IBJ
.. S Y=IBJN D DD^%DT S IBDATE=Y
.. S DFN=""
.. F S DFN=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ,DFN)) Q:DFN="" D
... S IBNAME=$P($G(^DPT(DFN,0)),U,1)
... S IBSSN=$P($G(^DPT(DFN,0)),U,9)
... S IBINS=""
... F S IBINS=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ,DFN,IBINS)) Q:IBINS="" D
.... D MSUB(IBJN)
W !
G SELINS
SELPAT D GATHER I IBNODATA Q
SELECT S DIC("A")="SELECT PATIENT TO RESTORE SUBSCRIBER ID'S FOR: "
S DIC(0)="AEINQ"
S DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
S DIC="^DPT("
D ^DIC
I $D(DTOUT)!($D(DUOUT))!((X="")&('$D(^TMP("IB20P244",$J,"SEL")))) G CHOICE1
I X="" W ! G SEL
S DFN=$P($G(Y),U,1)
M ^TMP("IB20P244",$J,"SEL",DFN)=^TMP("IB20P244",$J,"SUB",DFN)
S (X,Y)="" G SELECT
SEL ;RESTORE SELECTED PATIENTS SUBSCRIBER ID'S
S DFN=""
F S DFN=$O(^TMP("IB20P244",$J,"SEL",DFN)) Q:DFN="" D
. S IBNAME=$P($G(^DPT(DFN,0)),U,1)
. S IBSSN=$P($G(^DPT(DFN,0)),U,9)
. S IBJ=""
. F S IBJ=$O(^TMP("IB20P244",$J,"SEL",DFN,IBJ)) Q:IBJ="" D
.. S IBJN=-IBJ
.. S Y=IBJN D DD^%DT S IBDATE=Y
.. S IBINS=""
.. F S IBINS=$O(^TMP("IB20P244",$J,"SEL",DFN,IBJ,IBINS)) Q:IBINS="" D
... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
... D MSUB(IBJN)
W !
G SELPAT
SUBEXIT ;Cleans up temp globals
K ^TMP("IB20P244",$J)
K DIC,DIR,DTOUT,DUOUT
Q
GATHER K ^TMP("IB20P244",$J)
S IBJ=""
F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
. S DFN=""
. F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
.. S IBINS=""
.. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
... I SEL="PAT" S ^TMP("IB20P244",$J,"SUB",DFN,-IBJ,IBINS)="" Q
... S IBINSCO=$P($G(^DPT(DFN,.312,IBINS,0)),U,1)
... S ^TMP("IB20P244",$J,"SUB",IBINSCO,-IBJ,DFN,IBINS)=""
I '$D(^TMP("IB20P244")) W !,"There is no subscriber id data to restore!" S IBNODATA=1
Q
ALL S SCNT=0
S IBJ=""
F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
. S Y=IBJ D DD^%DT S IBDATE=Y
. S DFN=""
. F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
.. S IBNAME=$P($G(^DPT(DFN,0)),U,1)
.. S IBSSN=$P($G(^DPT(DFN,0)),U,9)
.. S IBINS=""
.. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
... S SCNT=SCNT+1
... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
... D MSUB(IBJ)
W !
I SCNT=0 W !,"There are no SUBSCRIBER ID entries to restore in the INSURANCE TYPE",!," SUB-FIELD (#2.312) file of the PATIENT (#2) file."
Q
MSUB(IBJN) ;Common subscriber id functionality merge/kill
S IBSUB=$P($G(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",1)
I IBSUB=$P($G(^DPT(DFN,.312,IBINS,0)),U,2) W !,"SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), entry "_IBINSNM_",",!," has already been restored!" D Q
. M ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
. K ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
S IBSUB1=$P($G(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",2)
I IBSUB1'=$P($G(^DPT(DFN,.312,IBINS,0)),U,2) W !,"SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), entry "_IBINSNM_", has been",!," changed since data conversion. Skipping restoral of this SUBSCRIBER ID." Q
I IBSUB[";" W !!,"Original SUBSCRIBER ID contains a semi-colon (;). Unable to restore",!," SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), insurance",!," company "_IBINSNM_". Use Fileman to enter",!," ID of """_IBSUB_""".",! Q
S DA=IBINS,DA(1)=DFN,DR="1////"_IBSUB,DIE="^DPT(DFN,.312," D ^DIE
W !,"The SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"),",!," insurance company "_IBINSNM_", has been restored",!," from the "_IBDATE_" data conversion."
M ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
K ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
Q
SUBPRNT ;Allows user to print an excel friendly list of subscriber id's changed
N DFN,IBINS,IBINSNM,IBJ,IBNAME
K ^TMP("IB20P244",$J)
S IBJ=""
F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
. S DFN=""
. F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
.. S IBNAME=$P($G(^DPT(DFN,0)),U,1)_"("_$P($G(^DPT(DFN,0)),U,9)_")"
.. I IBNAME="" S IBNAME="*** UNKNOWN ***"
.. S IBINS=""
.. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
... I IBINSNM="" S IBINSNM="*** UNKNOWN ***"
... S ^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,-IBJ,IBINS)=$G(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
I '$D(^TMP("IB20P244",$J,"SUB")) W !,"THERE IS NO DATA TO DISPLAY" Q
S IBINSNM=""
F S IBINSNM=$O(^TMP("IB20P244",$J,"SUB",IBINSNM)) Q:IBINSNM="" D
. S IBNAME=""
. F S IBNAME=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME)) Q:IBNAME="" D
.. S IBJ=""
.. F S IBJ=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ)) Q:IBJ="" D
... S IBINS=""
... F S IBINS=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ,IBINS)) Q:IBINS="" D
.... W !,IBINSNM_"^"_IBNAME_"^"_$G(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ,IBINS))
K ^TMP("IB20P244",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20R244 9376 printed Sep 23, 2025@19:41:52 Page 2
IB20R244 ;ISP/TDP - Restoral routine for IB*2.0*244 ;10/14/2003
+1 ;;2.0;INTEGRATED BILLING;**244**;21-MAR-94
+2 ; This routine is to restore data to the SUBSCRIBER ID (#1) field
+3 ; of the INSURANCE TYPE SUB-FIELD (#2.312) file of the PATIENT (#2)
+4 ; file and to the IB DM EXTRACT DATA (#351.71) file that was removed
+5 ; during the data conversion by post-init routine IB20P244 in patch
+6 ; IB*2.0*244. Data can only be restored if the ^XTMP("IB20P244" file
+7 ; still exists.
+8 QUIT
UNDOALL ;Undoes all the changes made by the post-init routine, based on what
+1 ;is stored in ^XTMP("IB20P244".
+2 NEW ALL,IBDIK
+3 SET ALL=1
SET IBDIK=0
+4 IF '$DATA(^XTMP("IB20P244",0))
WRITE !,"There is no data to restore."
QUIT
+5 DO UNDOP
+6 DO UNDOF
+7 DO UNDOSUB
+8 WRITE !!,"Data restoral complete."
+9 QUIT
UNDOP ;Restore the past date entries in file 351.71 which were deleted.
+1 NEW IBJ,PCNT,PDATE
+2 IF '$GET(ALL)
IF '$DATA(^XTMP("IB20P244",0))
WRITE !,"There is no data to restore."
QUIT
+3 SET PCNT=0
+4 SET IBJ=""
+5 FOR
SET IBJ=$ORDER(^XTMP("IB20P244",IBJ),-1)
if IBJ=""
QUIT
Begin DoDot:1
+6 SET PDATE=""
+7 FOR
SET PDATE=$ORDER(^XTMP("IB20P244",IBJ,"INS","PST",PDATE))
if PDATE=""
QUIT
Begin DoDot:2
+8 SET PCNT=PCNT+1
+9 DO MDATE(PDATE,"PST","RSTP")
End DoDot:2
End DoDot:1
+10 WRITE !
+11 IF PCNT=0
WRITE !,"There are no past date entries to restore for file 351.71."
+12 IF PCNT'=0
SET IBDIK=1
IF '$GET(ALL)
DO RENDX
KILL IBDIK
+13 QUIT
UNDOF ;Restore the future date entries in file 351.71 which were deleted.
+1 NEW IBJ,FCNT,FDATE
+2 IF '$GET(ALL)
IF '$DATA(^XTMP("IB20P244",0))
WRITE !,"There is no data to restore."
QUIT
+3 SET FCNT=0
+4 SET IBJ=""
+5 FOR
SET IBJ=$ORDER(^XTMP("IB20P244",IBJ),-1)
if IBJ=""
QUIT
Begin DoDot:1
+6 SET FDATE=""
+7 FOR
SET FDATE=$ORDER(^XTMP("IB20P244",IBJ,"INS","FUT",FDATE))
if FDATE=""
QUIT
Begin DoDot:2
+8 SET FCNT=FCNT+1
+9 DO MDATE(FDATE,"FUT","RSTF")
End DoDot:2
End DoDot:1
+10 WRITE !
+11 IF FCNT=0
WRITE !,"There are no future date entries to restore for file 351.71."
+12 IF FCNT'=0!($GET(IBDIK))
DO RENDX
+13 QUIT
RENDX ;Re-index file 351.71.
+1 WRITE !!,"Re-indexing file 351.71..."
+2 SET DIK="^IBE(351.71,"
DO IXALL^DIK
KILL DIK
+3 WRITE "Done"
+4 QUIT
MDATE(DATE,DTYP,DRTYP) ;Common date functionality merge/kill
+1 IF $ORDER(^IBE(351.71,DATE,""))'=""
WRITE !,"Entry already exists for "_DATE_". Skipping restoral of this date entry."
QUIT
+2 MERGE ^IBE(351.71,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
+3 MERGE ^XTMP("IB20P244",IBJ,"INS",DRTYP,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
+4 KILL ^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
+5 WRITE !,"The entry for "_DATE_" has been restored."
+6 QUIT
UNDOSUB ;Restore original SUBSCRIBER ID'S modified in the INSURANCE TYPE
+1 ;SUB-FIELD (#2.312) file of the PATIENT (#2) file.
+2 NEW DA,DFN,DIE,DR,IBDATE,IBINS,IBINSCO,IBINSNM,IBJ,IBJN,IBNAME,IBNODATA
+3 NEW IBSSN,IBSUB,IBSUB1,SCNT,SEL,X,Y
+4 IF '$GET(ALL)
IF '$DATA(^XTMP("IB20P244",0))
WRITE !,"There is no data to restore."
QUIT
+5 IF $GET(ALL)
WRITE !
GOTO ALL
CHOICE SET DIR("A")="DO YOU WANT TO RESTORE (A)LL OR (S)ELECTED SUBSCRIBER ID'S? "
+1 SET DIR("B")="QUIT"
+2 SET DIR("T")=300
+3 SET DIR("?")="Choose ALL to restore all subscriber id's, or choose SELECTED to choose individual patient's for restoral."
+4 SET DIR(0)="FAO^1:8^"
+5 DO ^DIR
+6 IF $EXTRACT(X,1)="S"
SET Y="SELECTED"
+7 IF $EXTRACT(X,1)="A"
SET Y="ALL"
+8 IF Y="QUIT"!(Y="")!($DATA(DTOUT))!($DATA(DUOUT))
GOTO SUBEXIT
+9 IF Y'="ALL"
IF Y'="SELECTED"
GOTO CHOICE
+10 IF Y="ALL"
WRITE !
GOTO ALL
CHOICE1 SET DIR("A")="DO YOU WANT TO RESTORE BY (P)ATIENT OR BY (I)NSURANCE COMPANY? "
+1 SET DIR("B")="QUIT"
+2 SET DIR("T")=300
+3 SET DIR("?")="Choose PATIENT to restore specific patient subscriber id's, or choose INSURANCE COMPANY to choose specific insurance companies for restoral."
+4 SET DIR(0)="FAO^1:8^"
+5 DO ^DIR
+6 SET IBNODATA=0
+7 IF $EXTRACT(X,1)="P"
SET Y="PATIENT"
+8 IF $EXTRACT(X,1)="I"
SET Y="INSURANCE COMPANY"
+9 IF Y="QUIT"!(Y="")!($DATA(DTOUT))!($DATA(DUOUT))
GOTO CHOICE
+10 IF Y'="PATIENT"
IF Y'="INSURANCE COMPANY"
GOTO CHOICE1
+11 IF Y="PATIENT"
WRITE !
SET SEL="PAT"
GOTO SELPAT
+12 WRITE !
+13 SET SEL="INS"
SELINS DO GATHER
IF IBNODATA
QUIT
SELECT1 SET DIC("A")="SELECT INSURANCE COMPANY TO RESTORE SUBSCRIBER ID'S FOR: "
+1 SET DIC(0)="AENQ"
+2 SET DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
+3 SET DIC="^DIC(36,"
+4 DO ^DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))!((X="")&('$DATA(^TMP("IB20P244",$JOB,"SEL"))))
GOTO CHOICE1
+6 IF X=""
WRITE !
GOTO SEL1
+7 SET IBINS=$PIECE($GET(Y),U,1)
+8 MERGE ^TMP("IB20P244",$JOB,"SEL",IBINS)=^TMP("IB20P244",$JOB,"SUB",IBINS)
+9 SET (X,Y)=""
GOTO SELECT1
SEL1 ;RESTORE SELECTED INSURANCE COMPANY SUBSCRIBER ID'S
+1 SET IBINSCO=""
+2 FOR
SET IBINSCO=$ORDER(^TMP("IB20P244",$JOB,"SEL",IBINSCO))
if IBINSCO=""
QUIT
Begin DoDot:1
+3 SET IBINSNM=$PIECE($GET(^DIC(36,IBINSCO,0)),U,1)
+4 SET IBJ=""
+5 FOR
SET IBJ=$ORDER(^TMP("IB20P244",$JOB,"SEL",IBINSCO,IBJ))
if IBJ=""
QUIT
Begin DoDot:2
+6 SET IBJN=-IBJ
+7 SET Y=IBJN
DO DD^%DT
SET IBDATE=Y
+8 SET DFN=""
+9 FOR
SET DFN=$ORDER(^TMP("IB20P244",$JOB,"SEL",IBINSCO,IBJ,DFN))
if DFN=""
QUIT
Begin DoDot:3
+10 SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+11 SET IBSSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+12 SET IBINS=""
+13 FOR
SET IBINS=$ORDER(^TMP("IB20P244",$JOB,"SEL",IBINSCO,IBJ,DFN,IBINS))
if IBINS=""
QUIT
Begin DoDot:4
+14 DO MSUB(IBJN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 WRITE !
+16 GOTO SELINS
SELPAT DO GATHER
IF IBNODATA
QUIT
SELECT SET DIC("A")="SELECT PATIENT TO RESTORE SUBSCRIBER ID'S FOR: "
+1 SET DIC(0)="AEINQ"
+2 SET DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
+3 SET DIC="^DPT("
+4 DO ^DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))!((X="")&('$DATA(^TMP("IB20P244",$JOB,"SEL"))))
GOTO CHOICE1
+6 IF X=""
WRITE !
GOTO SEL
+7 SET DFN=$PIECE($GET(Y),U,1)
+8 MERGE ^TMP("IB20P244",$JOB,"SEL",DFN)=^TMP("IB20P244",$JOB,"SUB",DFN)
+9 SET (X,Y)=""
GOTO SELECT
SEL ;RESTORE SELECTED PATIENTS SUBSCRIBER ID'S
+1 SET DFN=""
+2 FOR
SET DFN=$ORDER(^TMP("IB20P244",$JOB,"SEL",DFN))
if DFN=""
QUIT
Begin DoDot:1
+3 SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+4 SET IBSSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+5 SET IBJ=""
+6 FOR
SET IBJ=$ORDER(^TMP("IB20P244",$JOB,"SEL",DFN,IBJ))
if IBJ=""
QUIT
Begin DoDot:2
+7 SET IBJN=-IBJ
+8 SET Y=IBJN
DO DD^%DT
SET IBDATE=Y
+9 SET IBINS=""
+10 FOR
SET IBINS=$ORDER(^TMP("IB20P244",$JOB,"SEL",DFN,IBJ,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+11 SET IBINSNM=$PIECE($GET(^DIC(36,$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
+12 DO MSUB(IBJN)
End DoDot:3
End DoDot:2
End DoDot:1
+13 WRITE !
+14 GOTO SELPAT
SUBEXIT ;Cleans up temp globals
+1 KILL ^TMP("IB20P244",$JOB)
+2 KILL DIC,DIR,DTOUT,DUOUT
+3 QUIT
GATHER KILL ^TMP("IB20P244",$JOB)
+1 SET IBJ=""
+2 FOR
SET IBJ=$ORDER(^XTMP("IB20P244",IBJ),-1)
if IBJ=""
QUIT
Begin DoDot:1
+3 SET DFN=""
+4 FOR
SET DFN=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN))
if DFN=""
QUIT
Begin DoDot:2
+5 SET IBINS=""
+6 FOR
SET IBINS=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+7 IF SEL="PAT"
SET ^TMP("IB20P244",$JOB,"SUB",DFN,-IBJ,IBINS)=""
QUIT
+8 SET IBINSCO=$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,1)
+9 SET ^TMP("IB20P244",$JOB,"SUB",IBINSCO,-IBJ,DFN,IBINS)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF '$DATA(^TMP("IB20P244"))
WRITE !,"There is no subscriber id data to restore!"
SET IBNODATA=1
+11 QUIT
ALL SET SCNT=0
+1 SET IBJ=""
+2 FOR
SET IBJ=$ORDER(^XTMP("IB20P244",IBJ),-1)
if IBJ=""
QUIT
Begin DoDot:1
+3 SET Y=IBJ
DO DD^%DT
SET IBDATE=Y
+4 SET DFN=""
+5 FOR
SET DFN=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN))
if DFN=""
QUIT
Begin DoDot:2
+6 SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+7 SET IBSSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+8 SET IBINS=""
+9 FOR
SET IBINS=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+10 SET SCNT=SCNT+1
+11 SET IBINSNM=$PIECE($GET(^DIC(36,$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
+12 DO MSUB(IBJ)
End DoDot:3
End DoDot:2
End DoDot:1
+13 WRITE !
+14 IF SCNT=0
WRITE !,"There are no SUBSCRIBER ID entries to restore in the INSURANCE TYPE",!," SUB-FIELD (#2.312) file of the PATIENT (#2) file."
+15 QUIT
MSUB(IBJN) ;Common subscriber id functionality merge/kill
+1 SET IBSUB=$PIECE($GET(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",1)
+2 IF IBSUB=$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,2)
WRITE !,"SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), entry "_IBINSNM_",",!," has already been restored!"
Begin DoDot:1
+3 MERGE ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
+4 KILL ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
End DoDot:1
QUIT
+5 SET IBSUB1=$PIECE($GET(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",2)
+6 IF IBSUB1'=$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,2)
WRITE !,"SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), entry "_IBINSNM_", has been",!," changed since data conversion. Skipping restoral of this SUBSCRIBER ID."
QUIT
+7 IF IBSUB[";"
WRITE !!,"Original SUBSCRIBER ID contains a semi-colon (;). Unable to restore",!," SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"), insurance",!," company "_IBINSNM_". Use Fileman to enter",!," ID of """_IBSUB_""".",!
QUIT
+8 SET DA=IBINS
SET DA(1)=DFN
SET DR="1////"_IBSUB
SET DIE="^DPT(DFN,.312,"
DO ^DIE
+9 WRITE !,"The SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"),",!," insurance company "_IBINSNM_", has been restored",!," from the "_IBDATE_" data conversion."
+10 MERGE ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
+11 KILL ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
+12 QUIT
SUBPRNT ;Allows user to print an excel friendly list of subscriber id's changed
+1 NEW DFN,IBINS,IBINSNM,IBJ,IBNAME
+2 KILL ^TMP("IB20P244",$JOB)
+3 SET IBJ=""
+4 FOR
SET IBJ=$ORDER(^XTMP("IB20P244",IBJ),-1)
if IBJ=""
QUIT
Begin DoDot:1
+5 SET DFN=""
+6 FOR
SET DFN=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN))
if DFN=""
QUIT
Begin DoDot:2
+7 SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U,1)_"("_$PIECE($GET(^DPT(DFN,0)),U,9)_")"
+8 IF IBNAME=""
SET IBNAME="*** UNKNOWN ***"
+9 SET IBINS=""
+10 FOR
SET IBINS=$ORDER(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+11 SET IBINSNM=$PIECE($GET(^DIC(36,$PIECE($GET(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
+12 IF IBINSNM=""
SET IBINSNM="*** UNKNOWN ***"
+13 SET ^TMP("IB20P244",$JOB,"SUB",IBINSNM,IBNAME,-IBJ,IBINS)=$GET(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF '$DATA(^TMP("IB20P244",$JOB,"SUB"))
WRITE !,"THERE IS NO DATA TO DISPLAY"
QUIT
+15 SET IBINSNM=""
+16 FOR
SET IBINSNM=$ORDER(^TMP("IB20P244",$JOB,"SUB",IBINSNM))
if IBINSNM=""
QUIT
Begin DoDot:1
+17 SET IBNAME=""
+18 FOR
SET IBNAME=$ORDER(^TMP("IB20P244",$JOB,"SUB",IBINSNM,IBNAME))
if IBNAME=""
QUIT
Begin DoDot:2
+19 SET IBJ=""
+20 FOR
SET IBJ=$ORDER(^TMP("IB20P244",$JOB,"SUB",IBINSNM,IBNAME,IBJ))
if IBJ=""
QUIT
Begin DoDot:3
+21 SET IBINS=""
+22 FOR
SET IBINS=$ORDER(^TMP("IB20P244",$JOB,"SUB",IBINSNM,IBNAME,IBJ,IBINS))
if IBINS=""
QUIT
Begin DoDot:4
+23 WRITE !,IBINSNM_"^"_IBNAME_"^"_$GET(^TMP("IB20P244",$JOB,"SUB",IBINSNM,IBNAME,IBJ,IBINS))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 KILL ^TMP("IB20P244",$JOB)
+25 QUIT
