source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IB20R244.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IB20R244 ;ISP/TDP - Restoral routine for IB*2.0*244 ;10/14/2003
2 ;;2.0;INTEGRATED BILLING;**244**;21-MAR-94
3 ; This routine is to restore data to the SUBSCRIBER ID (#1) field
4 ; of the INSURANCE TYPE SUB-FIELD (#2.312) file of the PATIENT (#2)
5 ; file and to the IB DM EXTRACT DATA (#351.71) file that was removed
6 ; during the data conversion by post-init routine IB20P244 in patch
7 ; IB*2.0*244. Data can only be restored if the ^XTMP("IB20P244" file
8 ; still exists.
9 Q
10UNDOALL ;Undoes all the changes made by the post-init routine, based on what
11 ;is stored in ^XTMP("IB20P244".
12 N ALL,IBDIK
13 S ALL=1,IBDIK=0
14 I '$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
15 D UNDOP
16 D UNDOF
17 D UNDOSUB
18 W !!,"Data restoral complete."
19 Q
20UNDOP ;Restore the past date entries in file 351.71 which were deleted.
21 N IBJ,PCNT,PDATE
22 I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
23 S PCNT=0
24 S IBJ=""
25 F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
26 . S PDATE=""
27 . F S PDATE=$O(^XTMP("IB20P244",IBJ,"INS","PST",PDATE)) Q:PDATE="" D
28 .. S PCNT=PCNT+1
29 .. D MDATE(PDATE,"PST","RSTP")
30 W !
31 I PCNT=0 W !,"There are no past date entries to restore for file 351.71."
32 I PCNT'=0 S IBDIK=1 I '$G(ALL) D RENDX K IBDIK
33 Q
34UNDOF ;Restore the future date entries in file 351.71 which were deleted.
35 N IBJ,FCNT,FDATE
36 I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
37 S FCNT=0
38 S IBJ=""
39 F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
40 . S FDATE=""
41 . F S FDATE=$O(^XTMP("IB20P244",IBJ,"INS","FUT",FDATE)) Q:FDATE="" D
42 .. S FCNT=FCNT+1
43 .. D MDATE(FDATE,"FUT","RSTF")
44 W !
45 I FCNT=0 W !,"There are no future date entries to restore for file 351.71."
46 I FCNT'=0!($G(IBDIK)) D RENDX
47 Q
48RENDX ;Re-index file 351.71.
49 W !!,"Re-indexing file 351.71..."
50 S DIK="^IBE(351.71," D IXALL^DIK K DIK
51 W "Done"
52 Q
53MDATE(DATE,DTYP,DRTYP) ;Common date functionality merge/kill
54 I $O(^IBE(351.71,DATE,""))'="" W !,"Entry already exists for "_DATE_". Skipping restoral of this date entry." Q
55 M ^IBE(351.71,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
56 M ^XTMP("IB20P244",IBJ,"INS",DRTYP,DATE)=^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
57 K ^XTMP("IB20P244",IBJ,"INS",DTYP,DATE)
58 W !,"The entry for "_DATE_" has been restored."
59 Q
60UNDOSUB ;Restore original SUBSCRIBER ID'S modified in the INSURANCE TYPE
61 ;SUB-FIELD (#2.312) file of the PATIENT (#2) file.
62 N DA,DFN,DIE,DR,IBDATE,IBINS,IBINSCO,IBINSNM,IBJ,IBJN,IBNAME,IBNODATA
63 N IBSSN,IBSUB,IBSUB1,SCNT,SEL,X,Y
64 I '$G(ALL),'$D(^XTMP("IB20P244",0)) W !,"There is no data to restore." Q
65 I $G(ALL) W ! G ALL
66CHOICE S DIR("A")="DO YOU WANT TO RESTORE (A)LL OR (S)ELECTED SUBSCRIBER ID'S? "
67 S DIR("B")="QUIT"
68 S DIR("T")=300
69 S DIR("?")="Choose ALL to restore all subscriber id's, or choose SELECTED to choose individual patient's for restoral."
70 S DIR(0)="FAO^1:8^"
71 D ^DIR
72 I $E(X,1)="S" S Y="SELECTED"
73 I $E(X,1)="A" S Y="ALL"
74 I Y="QUIT"!(Y="")!($D(DTOUT))!($D(DUOUT)) G SUBEXIT
75 I Y'="ALL",Y'="SELECTED" G CHOICE
76 I Y="ALL" W ! G ALL
77CHOICE1 S DIR("A")="DO YOU WANT TO RESTORE BY (P)ATIENT OR BY (I)NSURANCE COMPANY? "
78 S DIR("B")="QUIT"
79 S DIR("T")=300
80 S DIR("?")="Choose PATIENT to restore specific patient subscriber id's, or choose INSURANCE COMPANY to choose specific insurance companies for restoral."
81 S DIR(0)="FAO^1:8^"
82 D ^DIR
83 S IBNODATA=0
84 I $E(X,1)="P" S Y="PATIENT"
85 I $E(X,1)="I" S Y="INSURANCE COMPANY"
86 I Y="QUIT"!(Y="")!($D(DTOUT))!($D(DUOUT)) G CHOICE
87 I Y'="PATIENT",Y'="INSURANCE COMPANY" G CHOICE1
88 I Y="PATIENT" W ! S SEL="PAT" G SELPAT
89 W !
90 S SEL="INS"
91SELINS D GATHER I IBNODATA Q
92SELECT1 S DIC("A")="SELECT INSURANCE COMPANY TO RESTORE SUBSCRIBER ID'S FOR: "
93 S DIC(0)="AENQ"
94 S DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
95 S DIC="^DIC(36,"
96 D ^DIC
97 I $D(DTOUT)!($D(DUOUT))!((X="")&('$D(^TMP("IB20P244",$J,"SEL")))) G CHOICE1
98 I X="" W ! G SEL1
99 S IBINS=$P($G(Y),U,1)
100 M ^TMP("IB20P244",$J,"SEL",IBINS)=^TMP("IB20P244",$J,"SUB",IBINS)
101 S (X,Y)="" G SELECT1
102SEL1 ;RESTORE SELECTED INSURANCE COMPANY SUBSCRIBER ID'S
103 S IBINSCO=""
104 F S IBINSCO=$O(^TMP("IB20P244",$J,"SEL",IBINSCO)) Q:IBINSCO="" D
105 . S IBINSNM=$P($G(^DIC(36,IBINSCO,0)),U,1)
106 . S IBJ=""
107 . F S IBJ=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ)) Q:IBJ="" D
108 .. S IBJN=-IBJ
109 .. S Y=IBJN D DD^%DT S IBDATE=Y
110 .. S DFN=""
111 .. F S DFN=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ,DFN)) Q:DFN="" D
112 ... S IBNAME=$P($G(^DPT(DFN,0)),U,1)
113 ... S IBSSN=$P($G(^DPT(DFN,0)),U,9)
114 ... S IBINS=""
115 ... F S IBINS=$O(^TMP("IB20P244",$J,"SEL",IBINSCO,IBJ,DFN,IBINS)) Q:IBINS="" D
116 .... D MSUB(IBJN)
117 W !
118 G SELINS
119SELPAT D GATHER I IBNODATA Q
120SELECT S DIC("A")="SELECT PATIENT TO RESTORE SUBSCRIBER ID'S FOR: "
121 S DIC(0)="AEINQ"
122 S DIC("S")="I $D(^TMP(""IB20P244"",$J,""SUB"",$P($G(Y),U,1)))"
123 S DIC="^DPT("
124 D ^DIC
125 I $D(DTOUT)!($D(DUOUT))!((X="")&('$D(^TMP("IB20P244",$J,"SEL")))) G CHOICE1
126 I X="" W ! G SEL
127 S DFN=$P($G(Y),U,1)
128 M ^TMP("IB20P244",$J,"SEL",DFN)=^TMP("IB20P244",$J,"SUB",DFN)
129 S (X,Y)="" G SELECT
130SEL ;RESTORE SELECTED PATIENTS SUBSCRIBER ID'S
131 S DFN=""
132 F S DFN=$O(^TMP("IB20P244",$J,"SEL",DFN)) Q:DFN="" D
133 . S IBNAME=$P($G(^DPT(DFN,0)),U,1)
134 . S IBSSN=$P($G(^DPT(DFN,0)),U,9)
135 . S IBJ=""
136 . F S IBJ=$O(^TMP("IB20P244",$J,"SEL",DFN,IBJ)) Q:IBJ="" D
137 .. S IBJN=-IBJ
138 .. S Y=IBJN D DD^%DT S IBDATE=Y
139 .. S IBINS=""
140 .. F S IBINS=$O(^TMP("IB20P244",$J,"SEL",DFN,IBJ,IBINS)) Q:IBINS="" D
141 ... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
142 ... D MSUB(IBJN)
143 W !
144 G SELPAT
145SUBEXIT ;Cleans up temp globals
146 K ^TMP("IB20P244",$J)
147 K DIC,DIR,DTOUT,DUOUT
148 Q
149GATHER K ^TMP("IB20P244",$J)
150 S IBJ=""
151 F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
152 . S DFN=""
153 . F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
154 .. S IBINS=""
155 .. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
156 ... I SEL="PAT" S ^TMP("IB20P244",$J,"SUB",DFN,-IBJ,IBINS)="" Q
157 ... S IBINSCO=$P($G(^DPT(DFN,.312,IBINS,0)),U,1)
158 ... S ^TMP("IB20P244",$J,"SUB",IBINSCO,-IBJ,DFN,IBINS)=""
159 I '$D(^TMP("IB20P244")) W !,"There is no subscriber id data to restore!" S IBNODATA=1
160 Q
161ALL S SCNT=0
162 S IBJ=""
163 F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
164 . S Y=IBJ D DD^%DT S IBDATE=Y
165 . S DFN=""
166 . F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
167 .. S IBNAME=$P($G(^DPT(DFN,0)),U,1)
168 .. S IBSSN=$P($G(^DPT(DFN,0)),U,9)
169 .. S IBINS=""
170 .. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
171 ... S SCNT=SCNT+1
172 ... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
173 ... D MSUB(IBJ)
174 W !
175 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."
176 Q
177MSUB(IBJN) ;Common subscriber id functionality merge/kill
178 S IBSUB=$P($G(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",1)
179 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
180 . M ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
181 . K ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
182 S IBSUB1=$P($G(^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)),"^",2)
183 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
184 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
185 S DA=IBINS,DA(1)=DFN,DR="1////"_IBSUB,DIE="^DPT(DFN,.312," D ^DIE
186 W !,"The SUBSCRIBER ID for "_IBNAME_" ("_IBSSN_"),",!," insurance company "_IBINSNM_", has been restored",!," from the "_IBDATE_" data conversion."
187 M ^XTMP("IB20P244",IBJN,"RSTS",DFN,IBINS)=^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
188 K ^XTMP("IB20P244",IBJN,"SUB",DFN,IBINS)
189 Q
190SUBPRNT ;Allows user to print an excel friendly list of subscriber id's changed
191 N DFN,IBINS,IBINSNM,IBJ,IBNAME
192 K ^TMP("IB20P244",$J)
193 S IBJ=""
194 F S IBJ=$O(^XTMP("IB20P244",IBJ),-1) Q:IBJ="" D
195 . S DFN=""
196 . F S DFN=$O(^XTMP("IB20P244",IBJ,"SUB",DFN)) Q:DFN="" D
197 .. S IBNAME=$P($G(^DPT(DFN,0)),U,1)_"("_$P($G(^DPT(DFN,0)),U,9)_")"
198 .. I IBNAME="" S IBNAME="*** UNKNOWN ***"
199 .. S IBINS=""
200 .. F S IBINS=$O(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS)) Q:IBINS="" D
201 ... S IBINSNM=$P($G(^DIC(36,$P($G(^DPT(DFN,.312,IBINS,0)),U,1),0)),U,1)
202 ... I IBINSNM="" S IBINSNM="*** UNKNOWN ***"
203 ... S ^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,-IBJ,IBINS)=$G(^XTMP("IB20P244",IBJ,"SUB",DFN,IBINS))
204 I '$D(^TMP("IB20P244",$J,"SUB")) W !,"THERE IS NO DATA TO DISPLAY" Q
205 S IBINSNM=""
206 F S IBINSNM=$O(^TMP("IB20P244",$J,"SUB",IBINSNM)) Q:IBINSNM="" D
207 . S IBNAME=""
208 . F S IBNAME=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME)) Q:IBNAME="" D
209 .. S IBJ=""
210 .. F S IBJ=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ)) Q:IBJ="" D
211 ... S IBINS=""
212 ... F S IBINS=$O(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ,IBINS)) Q:IBINS="" D
213 .... W !,IBINSNM_"^"_IBNAME_"^"_$G(^TMP("IB20P244",$J,"SUB",IBINSNM,IBNAME,IBJ,IBINS))
214 K ^TMP("IB20P244",$J)
215 Q
Note: See TracBrowser for help on using the repository browser.