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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1IBCNBAC ;ALB/ARH/DAOU/WCW-Ins Buffer: Individually Accept Insurance Buffer Fields ; 28-APR-03
2 ;;2.0;INTEGRATED BILLING;**184**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INS(IBBUFDA,IBINSDA,SKPBLANK) ; display a buffer entry's insurance company fields and an existing insurance company fields for comparison
6 N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
7 S SKPBLANK=$G(SKPBLANK)
8 ;
9 S IBEXTDA=$G(IBINSDA)_","
10 ;
11 I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",!
12 ;
13 W @IOF
14 W ! D WRTFLD(" Insurance Data: Buffer Data Selected Insurance Company ",0,80,"BU")
15 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
16 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U")
17 ;
18 D FIELDS("INS","",SKPBLANK)
19 ;
20 Q
21 ;
22GRP(IBBUFDA,IBGRPDA,SKPBLANK) ; display a buffer entrys group insurance fields and an existing group/plan's fields for comparison
23 N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
24 S SKPBLANK=$G(SKPBLANK)
25 ;
26 S IBEXTDA=$G(IBGRPDA)_","
27 ;
28 I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",!
29 ;
30 W @IOF
31 W ! D WRTFLD(" Group/Plan Data: Buffer Data Selected Group/Plan ",0,80,"BU")
32 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
33 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U")
34 ;
35 D FIELDS("GRP","",SKPBLANK)
36 ;
37 Q
38 ;
39POLICY(IBBUFDA,IBPOLDA,SKPBLANK) ; display a buffer entrys patient policy fields and an existing patient policy's fields for comparison
40 N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q
41 S SKPBLANK=$G(SKPBLANK)
42 S DFN=+$G(^IBA(355.33,IBBUFDA,60))
43 ;
44 S IBEXTDA=$G(IBPOLDA)_","_DFN_","
45 ;
46 W @IOF
47 W ! D WRTFLD(" Policy Data: Buffer Data Selected Policy ",0,80,"BU")
48 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
49 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","")
50 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","")
51 S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U")
52 ;
53 D FIELDS("POL","",SKPBLANK)
54 ;
55 I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP(SKPBLANK)
56 ;
57 Q
58 ;
59ESGHP(SKPBLANK) ; display employee sponsored group health plan
60 S SKPBLANK=$G(SKPBLANK)
61 W !!
62 ;
63 D FIELDS("POL",1,SKPBLANK)
64 ;
65 Q
66 ;
67FIELDS(SET,ESGHP,SKPBLANK) ; accept each field and set into temp array
68 N CHGCHK,IBFLDLST,IBFLDVAL,IBUSER,IBLABEL,EXTFILE,IBEXTFLD
69 S ESGHP=$G(ESGHP),SKPBLANK=$G(SKPBLANK)
70 ;
71 K IBFLDS,IBADDS,IBLBLS
72 ;
73 S EXTFILE=+$P($T(@(SET_"DR")+1^IBCNBMI),";;",2)
74 D FIELDS^IBCNBMI(SET_"FLD")
75 ;
76 S CHGCHK=0 ; Initialize variable to check for any items to accept
77 S IBBUFFLD=0 F S IBBUFFLD=$O(IBFLDS(IBBUFFLD)) Q:'IBBUFFLD I '$D(IBADDS(IBBUFFLD)) D Q:$G(IBUSER)<0
78 . I '$$ESGHPFLD(ESGHP,IBBUFFLD) Q
79 . ;
80 . S IBEXTFLD=IBFLDS(IBBUFFLD),IBLABEL=IBLBLS(IBBUFFLD)_":"
81 . S IBFLDVAL=$$DISPLAY(IBBUFFLD,EXTFILE,IBEXTFLD,IBLABEL)
82 . I $P(IBFLDVAL,U,1)=$P(IBFLDVAL,U,2) Q
83 . I SKPBLANK,$P(IBFLDVAL,U,1)="" Q
84 . ;
85 . S CHGCHK=1
86 . S IBUSER=$$ACCEPT($P(IBFLDVAL,U,1),$P(IBFLDVAL,U,2)) Q:IBUSER<0
87 . I +IBUSER S ^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)=""
88 ;
89 S IBFLDLST="" ; allow selection of address data in a group rather than individually
90 S IBBUFFLD=0 F S IBBUFFLD=$O(IBFLDS(IBBUFFLD)) Q:'IBBUFFLD I $D(IBADDS(IBBUFFLD)) D
91 . I '$$ESGHPFLD(ESGHP,IBBUFFLD) Q
92 . ;
93 . S IBEXTFLD=IBFLDS(IBBUFFLD),IBLABEL=IBLBLS(IBBUFFLD)_":"
94 . S IBFLDVAL=$$DISPLAY(IBBUFFLD,EXTFILE,IBEXTFLD,IBLABEL)
95 . I $P(IBFLDVAL,U,1)=$P(IBFLDVAL,U,2) Q
96 . I SKPBLANK,$P(IBFLDVAL,U,1)="" Q ; Do not prompt for blanks, if skipping
97 . S CHGCHK=1
98 . S IBFLDLST=IBFLDLST_IBBUFFLD_U
99 ;
100 I IBFLDLST'="" S IBUSER=$$ACCEPTG Q:IBUSER<0 D
101 . I +IBUSER F IBUSER=1:1 S IBBUFFLD=$P(IBFLDLST,U,IBUSER) Q:'IBBUFFLD S ^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)=""
102 ;
103 ; Display message if there were no changs to accept
104 I CHGCHK=0 W !!,"There are no changes to be accepted, based on the method of update chosen."
105 I CHGCHK=1 W !!,"End of changes for "_$S(SET="INS":"INSURANCE",SET="GRP":"GROUP",(SET="POL"&'ESGHP):"POLICY",1:"EMPLOYEE SPONSORED GROUP HEALTH PLAN")_" related data."
106 K DIR
107 D PAUSE^VALM1
108 ;
109 Q
110 ;
111ESGHPFLD(ESGHP,IBBUFFLD) ; return true if field should be included, if ESGHP thEN include all 61.* fields, else exclude those fields
112 N IBX,IBY S IBX=1 S ESGHP=$G(ESGHP)
113 S IBY=0 I IBBUFFLD>61,IBBUFFLD<61.99 S IBY=1
114 I +IBY,'ESGHP S IBX=0
115 I 'IBY,ESGHP S IBX=0
116 Q IBX
117 ;
118ACCEPT(BUFDATA,EXTDATA) ; ask user if they want to accept the change, returns true if yes
119 N IBX S IBX=0
120 I $G(BUFDATA)=$G(EXTDATA) Q
121 I BUFDATA="" S DIR("A")="Accept Change, Delete",DIR("?")="The Buffer field is null, accepting the change will result in the Insurance Company data ("_EXTDATA_") being deleted"
122 I BUFDATA'="" S DIR("A")="Accept Change, Replace",DIR("?")="Accepting the change will result Buffer data ("_BUFDATA_") replacing the Insurance Company data ("_EXTDATA_")"
123 S DIR(0)="Y",DIR("B")="No" D ^DIR I Y=1 S IBX=1
124 I $D(DIRUT)!$D(DTOUT) S IBX=-1
125 W !
126 Q IBX
127 ;
128 ;
129ACCEPTG() ; ask user if they want to accept the entire address change, returns true if yes
130 N IBX S IBX=0
131 S DIR("A")="Accept Address Change",DIR("?")="Accepting the change will result in the entire Buffer Address replacing the Insurance Company Address"
132 S DIR(0)="Y",DIR("B")="No" D ^DIR I Y=1 S IBX=1
133 I $D(DIRUT)!$D(DTOUT) S IBX=-1
134 W !
135 Q IBX
136 ;
137DISPLAY(BFLD,IFILE,IFLD,LABEL) ; extract, compare, write the two corresponding fields; one from buffer, one from ins files
138 N BUFDATA,EXTDATA,IBOVER,IBMERG,IBATTR,IBDATA S EXTDATA=""
139 S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD)
140 I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD)
141 S IBDATA=BUFDATA_U_EXTDATA
142 ;
143 S (IBOVER,IBMERG,IBATTR)=""
144 I BUFDATA'=EXTDATA S (IBOVER,IBMERG,IBATTR)="B"
145 ; When skipping blanks, display skipped items without bold
146 I SKPBLANK,BUFDATA="" S (IBOVER,IBMERG,IBATTR)=""
147 ;
148 D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG,IBATTR)
149 Q IBDATA
150 ;
151WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formated data with label and two fields
152 S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG)
153 S LABEL=$J(LABEL,17)_" ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2))
154 W !
155 D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG)
156 D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER)
157 Q
158 ;
159WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes
160 N ATTRB,ATTRE,DX,DY,X,Y
161 S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"")
162 S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"")
163 ;
164 S DX=COL,DY=$Y X IOXY
165 W ATTRB,$E(STRING,1,WD),ATTRE
166 S DX=(COL+WD),DY=$Y X IOXY
167 Q
Note: See TracBrowser for help on using the repository browser.