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

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1IBCNSU41 ;ALB/CPM - SPONSOR UTILITIES (CON'T) ; 5/9/03 1:25pm
2 ;;2.0;INTEGRATED BILLING;**52,211,240**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5SPON(DFN) ; Add/edit sponsor/sponsor relationships for a patient.
6 ; Input: DFN -- Pointer to the patient in file #2
7 ;
8 I '$G(DFN) G SPONQ
9 N IBQ S IBQ=0
10 F D LSP Q:IBQ
11SPONQ Q
12 ;
13 ;
14 ;
15LSP ; Main loop to collect sponsor and relation data.
16 S DIR(0)="FAO^3:30",DIR("A")="Select SPONSOR: " D ^DIR K DIR
17 I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) K DIRUT,DIROUT,DTOUT,DUOUT S IBQ=1 G LSPQ
18 S IBX=X
19 ;
20 ; - perform lookup to find sponsor or add a patient sponsor
21 S DIC(0)="ELMZ",DIC="^IBA(355.8,",DLAYGO=355.8 D ^DIC K DIC,DLAYGO
22 I Y>0 S IBSP=+Y,IBSPD=$G(^IBA(355.8,IBSP,0)),IBNAM=Y(0,0) G LSPC
23 I IBX'?1.A1","1.ANP W !,"New sponsors must be in the format LAST,FIRST.",! G LSP
24 ;
25 ; - is this a new sponsor to be added to the system?
26 S DIR(0)="Y",DIR("A")=" Are you adding '"_IBX_"' as a new SPONSOR"
27 D ^DIR K DIR
28 I 'Y!$D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) K DIRUT,DIROUT,DTOUT,DUOUT G LSP
29 ;
30 ; - add non-patient sponsor to file #355.82 (sponsor person file)
31 S (X,IBNAM)=IBX,DIC(0)="L",DIC="^IBA(355.82,",DLAYGO=355.82
32 D FILE^DICN S IBSPP=+Y K DLAYGO
33 I IBSPP<0 W !,"Unable to add a new sponsor!" G LSPQ
34 ;
35 ; - now add to file #355.8 (sponsor file)
36 S (IBSPD,X)=IBSPP_";IBA(355.82,",DIC(0)="L",DIC="^IBA(355.8,",DLAYGO=355.8
37 D FILE^DICN S IBSP=+Y K DLAYGO
38 I IBSP<0 W !,"Unable to add a new sponsor!" G LSPQ
39 ;
40LSPC ; - allow edit of non-patient sponsor name/dob/ssn
41 I $P(IBSPD,"^")["IBA" D
42 .S DIE="^IBA(355.82,",DA=+IBSPD
43 .S DR=".01 NAME;.02 DATE OF BIRTH;.03 SOCIAL SECURITY NUMBER"
44 .D ^DIE K DIE,DA,DR
45 ;
46 ; - edit remaining sponsor attributes
47 S DIE="^IBA(355.8,",DA=IBSP
48 S DR=".02 MILITARY STATUS;.03 BRANCH;.04 RANK"
49 D ^DIE K DA,DR,DIE
50 ;
51 ; - find patient relation to sponsor, or create one
52 S IBSPR=0 F S IBSPR=$O(^IBA(355.81,"B",DFN,IBSPR)) Q:'IBSPR I $P($G(^IBA(355.81,IBSPR,0)),"^",2)=IBSP Q
53 I 'IBSPR S IBQQ=0 D G:IBQQ LSPQ
54 .W !!,"The person '",IBNAM,"' is not currently the sponsor of this patient."
55 .S DIR(0)="Y",DIR("A")="Okay to add this person as the patient's sponsor"
56 .S DIR("?")="Please enter 'YES' to add this person as the patient's sponsor, or 'NO' to select a new sponsor."
57 .D ^DIR K DIR I 'Y W ! S IBQQ=1 Q
58 .;
59 .S X=DFN,DIC="^IBA(355.81,",DIC(0)="L",DIC("DR")=".02////"_IBSP,DLAYGO=355.81
60 .D FILE^DICN S IBSPR=+Y S:Y<0 IBQQ=1 K DLAYGO
61 ;
62 ; - edit sponsor relation attributes
63 S DIE="^IBA(355.81,",DA=IBSPR,DR=".03:.06" D ^DIE K DA,DIE,DR
64 W !
65 ;
66LSPQ K IBSP,IBSPD,IBSPP,IBSPR,IBQQ,IBNAM,IBX,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
67 Q
68 ;
69 ;
70 ;
71POL(DFN) ; Update TRICARE policies with Sponsor information.
72 ; Input: DFN -- Pointer to the patient in file #2
73 ;
74 I '$G(DFN) G POLQ
75 N IBX,IBY,SPON,X,X1,X3,Y,Z
76 ;
77 S X=0 F S X=$O(^IBA(355.81,"B",DFN,X)) Q:'X D Q:$D(Z)
78 .S Y=$G(^IBA(355.81,X,0))
79 .;
80 .; - relationship must be with a Tricare sponsor
81 .Q:$P(Y,"^",4)'="T"
82 .;
83 .S SPON=$G(^IBA(355.8,+$P(Y,"^",2),0)) Q:SPON=""
84 .;
85 .; - if sponsor is a patient, get name/dob/SSN from the patient
86 .; file; otherwise, use file #355.82
87 .I $P(SPON,"^")["DPT" D
88 ..S X1=$G(^DPT(+SPON,0)) Q:X1=""
89 ..S Z("NAME")=$P(X1,"^"),Z("DOB")=$P(X1,"^",3),Z("SSN")=$P(X1,"^",9)
90 .E D
91 ..S X1=$G(^IBA(355.82,+SPON,0)) Q:X1=""
92 ..S Z("NAME")=$P(X1,"^"),Z("DOB")=$P(X1,"^",2),Z("SSN")=$TR($P(X1,"^",3),"-","")
93 .;
94 .S Z("BRAN")=$P(SPON,"^",3),Z("RANK")=$P(SPON,"^",4)
95 ;
96 ; - if no Tricare sponsors were found, quit.
97 I '$D(Z) G POLQ
98 ;
99 ; - update any policies with TRICARE plans
100 S IBX=0 F S IBX=$O(^DPT(DFN,.312,IBX)) Q:'IBX S IBY=$G(^(IBX,0)) D
101 .;
102 .; - only consider TRICARE plans
103 .Q:$P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBY,"^",18),0)),"^",9),0)),"^",3)'=7
104 .;
105 .; - the policyholder should not be the veteran (patient)
106 .Q:$P(IBY,"^",6)="v"
107 .;
108 .; - if a sponsor DOB exists, be sure it's the same as the
109 .; sponsor file DOB
110 .S X3=$G(^DPT(DFN,.312,IBX,3))
111 .I X3,+X3'=Z("DOB") Q
112 .;
113 .S DR=""
114 .;IB*2*211
115 .I $P(IBY,"^",17)="" S DR=DR_"17////"_Z("NAME")_";"
116 .I $P(X3,"^")="",Z("DOB") S DR=DR_"3.01////"_Z("DOB")_";"
117 .I $P(X3,"^",2)="",Z("BRAN") S DR=DR_"3.02////"_Z("BRAN")_";"
118 .I $P(X3,"^",3)="",Z("RANK")]"" S DR=DR_"3.03////"_Z("RANK")_";"
119 .I $P(X3,"^",5)="",Z("SSN")]"" S DR=DR_"3.05////"_Z("SSN")_";"
120 .;
121 .Q:DR=""
122 .I $E(DR,$L(DR))=";" S DR=$E(DR,1,$L(DR)-1)
123 .;
124 .S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBX D ^DIE K DA,DIE,DR
125 ;
126POLQ Q
Note: See TracBrowser for help on using the repository browser.