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

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1IBCNSJ3 ;ALB/CPM - ADD NEW INSURANCE PLAN ; 11-JAN-95
2 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5NEW(IBCNS,IBCPOL,IBFG) ; Add a new insurance plan
6 ; Input: IBCNS -- Pointer to an insurance company in file #36
7 ; IBFG -- [Optional] -> Set to 1 to force creation
8 ; of a group plan
9 ; Output: IBCPOL -- 0, if a new plan was not added, or
10 ; >0 => pointer to the new plan in file #355.3
11 ;
12 N DA,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBTL,IBGRP,IBGNA,IBGNU,X,Y
13 S IBCPOL=0
14 I '$G(IBCNS) G NEWQ
15 ;
16 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add a new Insurance Plan"
17 S DIR("?")="If you have identified a new plan that has not been previously entered, and you wish to add it, answer 'YES'. If you do not wish to add a new plan, enter 'NO'."
18 D ^DIR K DIR I Y<1!($D(DIRUT)) G NEWQ
19 ;
20 ; - collect plan characteristics
21 I $G(IBFG) S IBGRP=1 G MORE
22 S DIR(0)="355.3,.02",DIR("A")=" IS THIS A GROUP PLAN" D ^DIR K DIR S IBGRP=Y
23 I $D(DIRUT) G NEWQ
24 ;
25MORE S IBTL=" "_$S(IBGRP:"GROUP",1:"INDIVIDUAL")_" PLAN "
26 S DIR(0)="355.3,.03",DIR("A")=IBTL_"NAME" D ^DIR K DIR G NEWQ:$D(DUOUT)!$D(DTOUT) S IBGNA=Y
27 S DIR(0)="355.3,.04",DIR("A")=IBTL_"NUMBER" D ^DIR K DIR G NEWQ:$D(DUOUT)!$D(DTOUT) S IBGNU=Y
28 ;
29 ; - check for duplicates and file the plan
30 I $$CHECK(IBCNS,IBGNA,IBGNU) S IBCPOL=$$ADDH^IBCNSU(IBCNS,IBGRP,IBGNA,IBGNU)
31NEWQ Q
32 ;
33 ;
34CHECK(IBCNS,IBGNA,IBGNU) ; Check for potential duplicate plans
35 ; Input: IBCNS -- Pointer to an insurance company in file #36
36 ; IBGNA -- Plan Name for potential new plan
37 ; IBGNU -- Plan Number for potential new plan
38 ; Output: IBANS -- 1 -> Okay to add the new plan
39 ; 0 -> Don't add the new plan.
40 ;
41 N IBANS,IBCT,IBCNSD
42 S (IBANS,IBCT)=1
43 S IBCNSD=$G(^DIC(36,+$G(IBCNS),0)) I IBCNSD="" G CHECKQ
44 K ^TMP($J,"DUP"),^TMP($J,"DUP1")
45 W !!," Searching for potential duplicate plans offered by ",$E($P(IBCNSD,"^"),1,20),"..."
46 I '$D(^IBA(355.3,"B",IBCNS)) G CHECKQ
47 ;
48 ; - look for potential duplicate plans
49 D:$G(IBGNA)]"" FIND(IBCNS,IBGNA)
50 D:$G(IBGNU)]"" FIND(IBCNS,IBGNU)
51 ;
52 ; - display potential duplicates and see if plan should be filed
53 I $D(^TMP($J,"DUP")) D LIST
54 ;
55CHECKQ I '$D(^TMP($J,"DUP")) W !!," No potential duplicate plans have been identified."
56 K ^TMP($J,"DUP"),^TMP($J,"DUP1")
57 Q IBANS
58 ;
59 ;
60FIND(IBCNS,IBGN) ; Check cross-references for duplicate plans
61 ; Input: IBCNS -- Pointer to the insurance company in file #36
62 ; IBGN -- value to use to find duplicates
63 ;
64 N INP,LEN,SUB,TYPE
65 F SUB="AGNA","AGNU","ACCP" D
66 .I SUB="ACCP" S IBGN=$$COMP^IBCNSJ(IBGN)
67 .S INP=IBGN,LEN=$L(INP) Q:LEN<2!(LEN>20)
68 .S TYPE=$S(IBGN?1N.N:"NUM",1:"STR")
69 .I $D(^IBA(355.3,SUB,IBCNS,INP)) D GDATA
70 .I TYPE="STR" F S INP=$O(^IBA(355.3,SUB,IBCNS,INP)) Q:$E(INP,1,LEN)'=IBGN D GDATA
71 .I TYPE="NUM" F S INP=$O(^IBA(355.3,SUB,IBCNS,INP)) Q:INP="" I $E(INP,1,LEN)=IBGN D GDATA
72 Q
73 ;
74GDATA ; Place potential duplicate plan into an array.
75 N X,Y S X=0
76 F S X=$O(^IBA(355.3,SUB,IBCNS,INP,X)) Q:'X I '$D(^TMP($J,"DUP",X)) D
77 .S Y=$G(^IBA(355.3,X,0)),IBCT=IBCT+1
78 .S ^TMP($J,"DUP",X)="",^TMP($J,"DUP1",IBCT)=$P(Y,"^",4)_U_$P(Y,"^",3)_U_$P(Y,"^",2)_U_$P(Y,"^",11)
79 Q
80 ;
81LIST ; List potential duplicates to screen and prompt to add plan.
82 W !!," The following plans have been identified as potential duplicates:"
83 W !!,?3,"PLAN",?22,"PLAN",?45,"GROUP",?55,"ACTIVE",!,?2,"NUMBER",?22,"NAME",?45,"PLAN?",?55,"PLAN?",!
84 S IBCT=0 F S IBCT=$O(^TMP($J,"DUP1",IBCT)) Q:'IBCT D
85 .S IBST=$G(^TMP($J,"DUP1",IBCT))
86 .W !?2,$S($P(IBST,"^")'="":$P(IBST,"^"),1:"<NO PLAN NUM>"),?22,$S($P(IBST,"^",2)'="":$P(IBST,"^",2),1:"<NO PLAN NAME>")
87 .W ?45,$S($P(IBST,"^",3)'="":$$EXPAND^IBTRE(355.3,.02,$P(IBST,"^",3)),1:"<UNK>"),?55,$S($P(IBST,"^",4):"NO",1:"YES")
88 ;
89 ; - see if it is okay to add the plan
90 S DIR(0)="Y",DIR("A",1)="Do you still want to add a new plan with Plan Name "_$S(IBGNA'="":IBGNA,1:"<NO PLAN NAME>")
91 S DIR("A")="and Plan Number "_$S(IBGNU'="":IBGNU,1:"<NO PLAN NUMBER>")
92 S DIR("B")="NO"
93 W ! D ^DIR K DIR S IBANS=Y
94 Q
Note: See TracBrowser for help on using the repository browser.