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

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1IBCNSJ51 ;ALB/TMP - INSURANCE PLAN MAINTENANCE ACTION PROCESSING (continued); 15-AUG-95
2 ;;Version 2.0 ; INTEGRATED BILLING ;**43**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EDCOV ; Add/edit limitations of coverage for a plan in IBCPOL
6 N IBTYP,IBEDT,IBCNT,IB1,IBOK,IBQUIT,IBOUT,IBCOV,Z,DONE,DONE1
7 G:'$G(IBCPOL) EDCOVEX
8 D FULL^VALM1
9 ;
10 ;
11 S DONE=0
12 F D Q:DONE ; Effective date selection
13 .K DIR
14 .W !
15 .S DIR(0)="DO",DIR("A")="Select EFFECTIVE DATE",DIR("?")="^D COVDTH^IBCNSJ51" S:$D(IBEDT) DIR("B")=$$DAT1^IBOUTL(IBEDT)
16 .D ^DIR W:$D(Y(0)) " ",Y(0) K DIR
17 .I $D(DIRUT) S DONE=1 Q
18 .S IBEDT=Y\1,IBCNT=0
19 .K IBTYP
20 .;
21 .S DONE1=0
22 .F D Q:DONE1 ; Coverage category type selection
23 ..K DIR
24 ..S DIR(0)="F"_$S(IBCNT:"O",1:"")_"^1:30",DIR("A")="Select "_$S(IBCNT:"another ",1:"")_"coverage category -OR- "_$S(IBCNT:"Press ENTER if selection is complete",1:"'ALL' to select all coverage categories")
25 ..S DIR("?")="^D COVTYPH^IBCNSJ51"
26 ..D ^DIR K DIR
27 ..I $D(DUOUT)!$D(DTOUT) S DONE1=1 Q
28 ..;
29 ..I Y'="" D Q:$TR(IBCNT,"al","AL")'="ALL"
30 ...I 'IBCNT,Y="ALL" S IBCNT="ALL",IBTYP=0 D Q
31 ....F S IBTYP=$O(^IBE(355.31,IBTYP)) Q:'IBTYP I $$WARN1(IBTYP) S IBTYP(IBTYP)=""
32 ...S DIC="^IBE(355.31,",DIC(0)="EMQ",X=Y D ^DIC
33 ...I Y<0 Q:'$$QUIT() S (DONE,DONE1)=1,IBCNT="" K IBTYP Q
34 ...I $D(IBTYP(+Y)) W !,"This category already selected." Q
35 ...S IBTYP=+Y I $$WARN1(IBTYP) S IBTYP(IBTYP)="",IBCNT=IBCNT+1
36 ..;
37 ..I $O(IBTYP(""))="" S (DONE,DONE1)=1 Q
38 ..;
39 ..S IBTYP=""
40 ..F S IBTYP=$O(IBTYP(IBTYP)) Q:IBTYP="" D Q:DONE1
41 ...K ^TMP($J,"IBCAT")
42 ...W !!,"Effective Date: ",$$DAT1^IBOUTL(IBEDT)," Coverage Category: ",$P($G(^IBE(355.31,+IBTYP,0)),U)
43 ...S DA=$O(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT,""))
44 ...I DA'="" D SAVE^IBCNSJ52(DA) W !,"Editing existing record.",!
45 ...I DA="" D Q:'DA ;Add a new record
46 ....S DIR(0)="Y",DIR("A",1)="A new record will be added for this EFFECTIVE DATE/coverage category.",DIR("A")="Is this OK",DIR("B")="YES" D ^DIR K DIR
47 ....I Y'=1 S:$$QUIT() (DONE,DONE1)=1 Q
48 ....K DO,DD
49 ....S DIC="^IBA(355.32,",DIC(0)="L",X=IBCPOL,DIC("DR")=".02////"_IBTYP_";.03////"_IBEDT_";.04////1" D FILE^DICN
50 ....S DA=$S(Y>0:+Y,1:0)
51 ....W:DA !,"New record added.",!
52 ...;
53 ...S IBCOV=DA
54 ...;
55 ...L +^IBA(355.32,IBCOV):5 I '$T D LOCKED^IBTRCD1 Q
56 ...S DIE="^IBA(355.32,",DR=".04;S Y=$S(X'>1:"""",1:2);2"
57 ...D ^DIE S IBOUT=$D(Y)
58 ...I $P($G(^IBA(355.32,IBCOV,0)),U,4)'>1,$O(^(2,0)) S Z=0 F S Z=$O(^IBA(355.32,IBCOV,2,Z)) Q:'Z S DIK="^IBA(355.32,"_IBCOV_",2,",DA(1)=IBCOV,DA=Z D ^DIK ;Delete comments
59 ...I $$DIFFLIM^IBCNSJ52(IBCOV) S DIE="^IBA(355.32,",DA=IBCOV,DR="1.03///NOW;1.04////^S X=DUZ" D ^DIE ;Update user who edited entry
60 ...L -^IBA(355.32,IBCOV)
61 ...;
62 ...I IBOUT,$$QUIT() S (DONE,DONE1)=1
63 ..K IBTYP S IBCNT=0
64 ;
65EDCOVEX S VALMBCK="R"
66 K ^TMP($J,"IBCOV")
67 Q
68 ;
69QUIT() ; Quit coverage limitation loop
70 N DIR,Y
71 S DIR(0)="Y",DIR("A")="Do you want to exit this function now",DIR("B")="YES" D ^DIR
72 Q Y
73 ;
74COVDTH ; Help text for selecting effective date on coverage add/edit
75 N Z,Z0,ZX,CT
76 D HELP^%DTC
77 I $O(^IBA(355.32,"APCD",IBCPOL,""))="" W !!,"No current dates on file for this plan." Q
78 W !!,"Current dates on file for this plan:"
79 S Z="" F S Z=$O(^IBA(355.32,"APCD",IBCPOL,Z)) Q:'Z S Z0="" F S Z0=$O(^IBA(355.32,"APCD",IBCPOL,Z,Z0)) Q:'Z0 S ZX(Z0,Z)=""
80 S Z="" F S Z=$O(ZX(Z)) Q:'Z W !,?3,$$DAT1^IBOUTL(-Z)," -" S Z0="",CT=0 F S Z0=$O(ZX(Z,Z0)) Q:'Z0!(CT>3) S CT=CT+1 W " ",$P($G(^IBE(355.31,Z0,0)),U) W:CT=4&($O(ZX(Z,Z0))'="") " (and more)"
81 Q
82 ;
83COVTYPH ; Help text for selecting coverage category on coverage add/edit
84 W !!,"Enter a coverage category to add/edit coverage limitations for.",!
85 S DIC="^IBE(355.31,",DIC(0)="M",X="?" D ^DIC
86 I '$G(IBCNT) W !,"Enter ALL to select all coverage categories."
87 W !,"You may enter multiple coverage categories by entering them one at a time.",!,"After you have selected all needed categories, press ENTER at this prompt to",!,"continue."
88 Q
89 ;
90WARN1(IBTYP) ; Warning if adding/editing an earlier effective date than latest one on file
91 N IB1,Y
92 S IB1=$O(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-9999999)),Y=1
93 I IB1'="",IB1<-IBEDT D
94 .W !
95 .S DIR(0)="Y",DIR("A",1)="An effective date later than the one you selected",DIR("A",2)="already exists for "_$P($G(^IBE(355.31,IBTYP,0)),U)_"."
96 .S DIR("A")=" Are you sure you want to "_$S($D(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)):"edit",1:"add")_" this earlier date for the category",DIR("B")="NO"
97 .D ^DIR K DIR
98 .W !
99 Q (Y=1)
100 ;
Note: See TracBrowser for help on using the repository browser.