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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1IBYAPT ;ALB/CPM - PATCH IB*2*28 POST-INITIALIZATION ; 25-JAN-95
2 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
3 ;
4EN ; Patch IB*2*28 post initialization.
5 ;
6 D DEL ; delete IBCNS QUIT as an item of IBCNSC INSURANCE CO
7 D ^IBYAONIT ; install protocols
8 D BLD ; update ^XUTL("XQORM" for menu protocols
9 D TEM ; install list templates
10 D ADD ; add new option to the Ins Mgmt menu
11 D REF ; build x-refs
12 D BKG^IBYAPT1 ; queue off insurance clean-up
13 Q
14 ;
15 ;
16DEL ; Delete IBCNS QUIT from the item multiple of IBCNSC INSURANCE CO.
17 S DIC(0)="F",DIC="^ORD(101,",X="IBCNSC INSURANCE CO"
18 D ^DIC K DIC Q:Y<0 S IBMENU=+Y
19 S DIC(0)="F",DIC="^ORD(101,"_IBMENU_",10,",DA(1)=IBMENU,X="IBCNS QUIT"
20 D ^DIC K DIC Q:Y<0 S IBITEM=+Y
21 W !!,">>> Deleting protocol IBCNS QUIT as an item of IBCNSC INSURANCE CO..."
22 W !," (It will be added back in momentarily)"
23 S DA(1)=IBMENU,DA=IBITEM,DIK="^ORD(101,"_IBMENU_",10," D ^DIK
24 K DA,DIK,IBITEM,IBMENU
25 Q
26 ;
27BLD ; Update ^XUTL("XQORM" for menu protocols.
28 W !
29 F IBX="IBCNSJ PLAN LOOKUP","IBCNSP POLICY MENU","IBCNSC INSURANCE CO" D
30 .S DIC="^ORD(101,",DIC(0)="F",X=IBX D ^DIC K DIC S IBY=+Y
31 .I IBY>0 D
32 ..W !,">>> Rebuilding ^XUTL(""XQORM"" for protocol '",IBX,"' ..."
33 ..S XQORM=IBY_";ORD(101," D XREF^XQORM
34 K IBX,IBY,ORULT,X,XQORM,Y
35 Q
36 ;
37TEM ; Install List Templates
38 W !!,">>> Installing List Templates..."
39 W !,"'IBCNS EXPANDED POLICY' List Template..."
40 S DA=$O(^SD(409.61,"B","IBCNS EXPANDED POLICY",0)),DIK="^SD(409.61," D ^DIK:DA
41 K DO,DD S DIC(0)="L",DIC="^SD(409.61,",X="IBCNS EXPANDED POLICY" D FILE^DICN S VALM=+Y
42 I VALM>0 D
43 .S ^SD(409.61,VALM,0)="IBCNS EXPANDED POLICY^1^^80^5^17^1^1^Policy^IBCNSP POLICY MENU^Patient Policy Information^1"
44 .S ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
45 .S ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSVP"",$J)"
46 .S ^SD(409.61,VALM,"COL",0)="^409.621^^0"
47 .S ^SD(409.61,VALM,"FNL")="D EXIT^IBCNSP"
48 .S ^SD(409.61,VALM,"HDR")="D HDR^IBCNSP"
49 .S ^SD(409.61,VALM,"HLP")="D HELP^IBCNSP"
50 .S ^SD(409.61,VALM,"INIT")="D INIT^IBCNSP"
51 .S DA=VALM,DIK="^SD(409.61," D IX1^DIK K DA,DIK
52 .W "Filed."
53 ;
54 W !,"'IBCNS PLAN LOOKUP' List Template..."
55 S DA=$O(^SD(409.61,"B","IBCNS PLAN LOOKUP",0)),DIK="^SD(409.61," D ^DIK:DA
56 K DO,DD S DIC(0)="L",DIC="^SD(409.61,",X="IBCNS PLAN LOOKUP" D FILE^DICN S VALM=+Y
57 I VALM>0 D
58 .S ^SD(409.61,VALM,0)="IBCNS PLAN LOOKUP^1^^80^7^19^1^1^Plan^IBCNSJ PLAN LOOKUP^Insurance Plan Lookup^1^^1"
59 .S ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
60 .S ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSJ"",$J)"
61 .S ^SD(409.61,VALM,"COL",0)="^409.621^8^8"
62 .S ^SD(409.61,VALM,"COL",1,0)="NUMBER^1^4^"
63 .S ^SD(409.61,VALM,"COL",2,0)="GNAME^5^18^Group Name"
64 .S ^SD(409.61,VALM,"COL",3,0)="GNUM^25^17^Group Number"
65 .S ^SD(409.61,VALM,"COL",4,0)="TYPE^44^13^Type of Plan"
66 .S ^SD(409.61,VALM,"COL",5,0)="UR^59^3^UR?"
67 .S ^SD(409.61,VALM,"COL",6,0)="PREC^64^3^Ct?"
68 .S ^SD(409.61,VALM,"COL",7,0)="PREEX^70^4^ExC?"
69 .S ^SD(409.61,VALM,"COL",8,0)="BENAS^76^3^As?"
70 .S ^SD(409.61,VALM,"FNL")="D FNL^IBCNSU2"
71 .S ^SD(409.61,VALM,"HDR")="D HDR^IBCNSU2"
72 .S ^SD(409.61,VALM,"HLP")="S X=""?"" D DISP^XQORM1 W !!"
73 .S ^SD(409.61,VALM,"INIT")="D INIT^IBCNSU2"
74 .S DA=VALM,DIK="^SD(409.61," D IX1^DIK K DA,DIK
75 .W "Filed."
76 ;
77 K DIC,DIK,VALM,X,DA Q
78 ;
79ADD ; Add the option List Plans by Insurance Company to the Ins Mgmt menu
80 S (IBUY,Y)=$O(^DIC(19,"B","IBCN INSURANCE MGMT MENU",0)) Q:Y=""
81 S X=$O(^DIC(19,"B","IBCN LIST PLANS BY INS CO",0)) Q:X=""
82 W !!,">>> Adding IBCN LIST PLANS BY INS CO option to the IBCN INSURANCE MGMT MENU..."
83 I '$D(^DIC(19,+Y,10,0)) S ^DIC(19,+Y,10,0)="^19.01IP^0^0"
84 S (DA,D0)=+Y,DIC="^DIC(19,"_+Y_",10,",DIC(0)="L",DA(1)=+Y,DLAYGO=19.01,X="IBCN LIST PLANS BY INS CO" D ^DIC
85 S DA=+Y,DIE="^DIC(19,"_DA(1)_",10,",DR="2///^S X=""LP""" D ^DIE
86 K DIC,DIE,DA,IBUY,DR,X,Y
87 Q
88 ;
89REF ; Build the ACCP, AGNA, and AGNU cross-references.
90 W !!,">>> Building the 'ACCP' cross-reference for file #355.3 ..."
91 W !," (I'll write a dot for every 100 entries processed)",!
92 S (IBCT,IBP)=0
93 F IB=1:1 S IBP=$O(^IBA(355.3,IBP)) Q:'IBP S IBPD=$G(^(IBP,0)) I IBPD D
94 .W:'(IB#100) "."
95 .S IBX=$P(IBPD,"^",3) I IBX]"" D
96 ..S ^IBA(355.3,"AGNA",+IBPD,IBX,IBP)=""
97 ..S Y=$$COMP^IBCNSJ(IBX) I Y]"" S ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
98 .S IBX=$P(IBPD,"^",4) I IBX]"" D
99 ..S ^IBA(355.3,"AGNU",+IBPD,IBX,IBP)=""
100 ..S Y=$$COMP^IBCNSJ(IBX) I Y]"" S ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
101 .I $P(IBPD,"^",2),$P(IBPD,"^",10) D
102 ..S DIE="^IBA(355.3,",DA=IBP,DR=".1////@;1.05///NOW;1.06////"_DUZ
103 ..D ^DIE K DIE,DA,DR S IBCT=IBCT+1
104 I IBCT W !?4,"Note that ",IBCT," group plan",$S(IBCT>1:"s",1:"")," had the individual policy pointer removed."
105 K IBCT,IBP,IB,IBPD,IBX,Y
106 Q
Note: See TracBrowser for help on using the repository browser.