close Warning: Can't use blame annotator: 
svn blame failed on WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSCD1.m: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSCD1.m@ 846

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
1IBCNSCD1 ;ALB/CPM - DELETE INSURANCE COMPANY (CON'T) ; 02-FEB-95
2 ;;2.0;INTEGRATED BILLING;**28,46,80**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DQ ; Queued entry point for the final clean-up job.
6 ;
7 K ^TMP($J,"IBCNSCD")
8 L +^IB("IBCNSCD"):5 E G DDQ ; another clean-up job got started
9 S IBC=0 F S IBC=$O(^DIC(36,"ADEL",IBC)) Q:'IBC S ^TMP($J,"IBCNSCD",IBC)=$P($G(^DIC(36,IBC,5)),"^",2)
10 I '$D(^TMP($J,"IBCNSCD")) G DDQ ; no companies to be deleted
11 ;
12 D NOW^%DTC S IBBDT=%
13 ;
14 ; - dispositions
15 S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN S IBC=0 F S IBC=$O(^DPT(DFN,"DIS",IBC)) Q:'IBC S IBCO=$P($G(^(IBC,2)),"^",6) I IBCO,$D(^TMP($J,"IBCNSCD",IBCO)) D
16 .S $P(^DPT(DFN,"DIS",IBC,2),"^",6)=$G(^TMP($J,"IBCNSCD",IBCO))
17 .S IBCT("DIS")=$G(IBCT("DIS"))+1
18 .I $G(^TMP($J,"IBCNSCD",IBCO))="" S IBCT("DIS",DFN,IBC)=""
19 ;
20 ; - insurance companies
21 S IBC=0 F S IBC=$O(^DIC(36,IBC)) Q:'IBC D
22 .S IB0=$G(^DIC(36,IBC,0)),IB12=$G(^(.12)),IB13=$G(^(.13)),IB14=$G(^(.14)),IB16=$G(^(.16)),IB18=$G(^(.18))
23 .K IBV
24 .I $P(IB0,"^",16),$D(^TMP($J,"IBCNSCD",$P(IB0,"^",16))) S IBV(0)="16^"_^($P(IB0,"^",16))
25 .I $P(IB12,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB12,"^",7))) S IBV(.12)="7^"_^($P(IB12,"^",7))
26 .I $P(IB13,"^",9),$D(^TMP($J,"IBCNSCD",$P(IB13,"^",9))) S IBV(.13)="9^"_^($P(IB13,"^",9))
27 .I $P(IB14,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB14,"^",7))) S IBV(.14)="7^"_^($P(IB14,"^",7))
28 .I $P(IB16,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB16,"^",7))) S IBV(.16)="7^"_^($P(IB16,"^",7))
29 .I $P(IB18,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB18,"^",7))) S IBV(.18)="7^"_^($P(IB18,"^",7))
30 .Q:'$D(IBV)
31 .;
32 .; - delete or repoint
33 .S IBX="" F S IBX=$O(IBV(IBX)) Q:IBX="" D
34 ..S $P(^DIC(36,IBC,IBX),"^",+IBV(IBX))=$P(IBV(IBX),"^",2)
35 ..S IBCT("INS",IBX)=$G(IBCT("INS",IBX))+1
36 ..I $P(IBV(IBX),"^",2)="" S IBCT("INS",IBX,IBC)=""
37 ;
38 ; - insurance reviews
39 S IBC=0 F S IBC=$O(^IBT(356.2,IBC)) Q:'IBC S IBCO=$P($G(^(IBC,0)),"^",8) I IBCO,$D(^TMP($J,"IBCNSCD",IBCO)) S IBCD=$G(^IBT(356.2,IBC,0)) D
40 .S IBVAL=$G(^TMP($J,"IBCNSCD",IBCO)) I 'IBVAL S IBVAL="@"
41 .S DA=IBC,DR=".08////"_IBVAL,DIE="^IBT(356.2," D ^DIE K DA,DIE,DR
42 .S IBCT("IR")=$G(IBCT("IR"))+1
43 .I IBVAL="@" S IBCT("IR",+$P(IBCD,"^",5),+IBCD)=""
44 ;
45 ; - bills
46 S IBC=0 F S IBC=$O(^DGCR(399,IBC)) Q:'IBC S IBCNS=0 F S IBCNS=$O(^DGCR(399,IBC,"AIC",IBCNS)) Q:'IBCNS I $D(^TMP($J,"IBCNSCD",IBCNS)) S (IBREP,IBVAL)=$G(^(IBCNS)) D FIND
47 ;
48 ; - call AR to handle receivables
49 S IBCTAR=0 D INS2^RCAMINS("^TMP($J,""IBCNSCD"")",.IBCTAR)
50 ;
51 D NOW^%DTC S IBEDT=%
52 ;
53 ; - mail results
54 D MAIL^IBCNSCD2
55 ;
56 ; - finally, delete the companies
57 S IBC=0 F S IBC=$O(^TMP($J,"IBCNSCD",IBC)) Q:'IBC S DA=IBC,DIK="^DIC(36,",DIDEL=36 D ^DIK
58 ;
59 ; - delete task number from #350.9
60 S $P(^IBE(350.9,1,4),"^",8)=""
61 ;
62DDQ K IBC,IBCT,^TMP($J,"IBCNSCD")
63 L -^IB("IBCNSCD")
64 S ZTREQ="@"
65 Q
66 ;
67 ;
68FIND ; Find the carrier somewhere in the bill.
69 ; Required local variables are those described in CARR.
70 S IB0=$G(^DGCR(399,IBC,0)),IBM=$G(^("M"))
71 ;
72 ; - look for the carrier
73 I +IBM=IBCNS D CARR(1,"I1") ; primary
74 I $P(IBM,"^",2)=IBCNS D CARR(2,"I2") ; secondary
75 I $P(IBM,"^",3)=IBCNS D CARR(3,"I3") ; tertiary
76 ;
77 ; - kill off the x-ref
78 K ^DGCR(399,IBC,"AIC",IBCNS)
79 Q
80 ;
81CARR(IBP,IBSUB) ; Update each carrier.
82 ; Input: IBP -- carrier [1:primary 2:secondary 3:tertiary]
83 ; IBSUB -- updated subscript ["I1":prim "I2":sec "I3":tert]
84 ;
85 ; The following local variables are also required to be defined:
86 ; IBCNS, IB0, IBM, IBC, IBREP, IBVAL
87 ;
88 S IBCNS1=+IBREP
89 S $P(^DGCR(399,IBC,"M"),"^",IBP)=IBVAL
90 I $G(^DGCR(399,IBC,IBSUB))]"" S $P(^(IBSUB),"^",1)=IBVAL
91 I IBVAL="" D
92 .S IBS=0
93 .I $P(IB0,"^",2) S IBCNS1=+$G(^DPT($P(IB0,"^",2),.312,+$P(IBM,"^",IBP+11),0)) I IBCNS1 S IBS=1,$P(^DGCR(399,IBC,"M"),"^",IBP)=IBCNS1 S:$G(^(IBSUB))]"" $P(^(IBSUB),"^",1)=IBCNS1
94 .I 'IBS S IBCT("BL",IBP,IBC)=""
95 ;
96 I IBCNS1 S ^DGCR(399,IBC,"AIC",IBCNS1)=""
97 ;
98 I IBCNS=+$G(^DGCR(399,IBC,"MP")) D
99 .I $P(IB0,"^",2),+IBCNS K ^DGCR(399,"AE",$P(IB0,"^",2),IBCNS,IBC)
100 .S $P(^DGCR(399,IBC,"MP"),U,1)=IBCNS1
101 .I $P(IB0,"^",2),+IBCNS1 S ^DGCR(399,"AE",$P(IB0,"^",2),+IBCNS1,IBC)=""
102 ;
103 S IBCT("BL",IBP)=$G(IBCT("BL",IBP))+1
104 Q
105 ;
106 ;
107BILL(IBBILLN,IBCNS,IBREP) ; Callable Entry Point for Accounts Receivable
108 ; Input: IBBILLN -- Bill Number for bill to be repointed
109 ; IBCNS -- Pointer to the insurance company in file #36
110 ; that is being merged
111 ; IBREP -- Pointer to the insurance company in file #36
112 ; into which information is being merged
113 ;
114 N IBC,IBCT,IBVAL,IBCNS1,IB0,IBM
115 I $G(IBBILLN)=""!'$G(IBCNS)!($G(IBREP)="") G BILLQ
116 S IBC=$O(^DGCR(399,"B",IBBILLN,0)) I 'IBC G BILLQ
117 S IBVAL=$S(IBREP:IBREP,1:"")
118 D FIND
119BILLQ Q
Note: See TracBrowser for help on using the repository browser.