IBCNSJ51 ;ALB/TMP - INSURANCE PLAN MAINTENANCE ACTION PROCESSING (continued); 15-AUG-95
;;2.0;INTEGRATED BILLING;**43,631,664**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
EDCOV ; Add/edit limitations of coverage for a plan in IBCPOL
;/IB*2.0*631/vd - Added the variables IBALL and OPTN (for US4555)
N DIC,DIE,DR,DONE,DONE1,IB1,IBALL,IBCOV,IBCNT,IBEDT,IBEDT1,IBOK,IBOUT,IBQUIT,IBTYP,OPTN,Z
G:'$G(IBCPOL) EDCOVEX
D FULL^VALM1
;
S (DONE,OPTN)=0
S DONE=0
F D Q:DONE!(OPTN<0) ; Effective date selection
.K DIR
.W !
.S DIR(0)="DO",DIR("A")="Select EFFECTIVE DATE",DIR("?")="^D COVDTH^IBCNSJ51" S:$D(IBEDT) DIR("B")=$$DAT1^IBOUTL(IBEDT)
.D ^DIR W:$D(Y(0)) " ",Y(0) K DIR
.I $D(DIRUT) S DONE=1 Q
.;IB*2.0*664/TAZ - Initialize IBEDT1 to equal the selected Effective Date.
.S (IBEDT,IBEDT1)=Y\1,IBCNT=0
.K IBTYP
.;IB*2.0*664/TAZ - Check for imprecise date and prompt for a precise date for filing.
.I '$$PRECISE(DT,IBEDT) D I DONE S DONE=0 Q ; Reset DONE to not Quit out totally on BAD DATES.
.. I $$EXISTS(IBCPOL,IBEDT) D Q ; Check to see if there are any categories for the selected policy and imprecise date.
... S IBALL="ALL",DA=""
... K IBTYP S IBTYP=0
... F S IBTYP=$O(^IBE(355.31,IBTYP)) Q:'IBTYP D
.... I $D(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)) S IBTYP(IBTYP)=""
... D DELETE(IBALL,IBEDT,DA) ; Check if the existing categories should be deleted for the imprecise date.
... S DONE=1
... Q
..;
.. S DIR("A")="Enter a new precise EFFECTIVE DATE"
.. S DIR("A",1)="You have entered an imprecise date. You must enter a precise date to"
.. S DIR("A",2)="edit/add a Coverage Limitation."
.. S DIR("A",4)=""
.. S DIR(0)="D^::EX"
.. D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S DONE=1 Q
.. S (IBEDT,IBEDT1)=Y\1
.;
.S DONE1=0
.F D Q:DONE1!(OPTN<0) ; Coverage category type selection
..K DIR
..W !
..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")
..S DIR("?")="^D COVTYPH^IBCNSJ51"
..D ^DIR K DIR
..I $D(DUOUT)!$D(DTOUT) S DONE1=1 Q
..;
..S IBALL=Y ;/IB*2.0*631 - vd - Preserving the 'Y' variable in the IBALL variable so it won't get stepped on.
..;/IB*2.0*631 - vd - Added some new prompting and deleting capabilities below.
..I IBALL="ALL" D
...S OPTN="E",IBTYP=0 ; Default OPTN to EDIT...if no categories exist for date...we just want to ADD. No need to ask 'Edit or Delete' question.
...I $$EXISTS(IBCPOL,IBEDT) S OPTN="" ; Check to see if there are existing categories for the date entered.
...I OPTN="" S OPTN=$$ASK(0) Q:(OPTN<0)
..I IBALL'="" D Q:$TR(IBCNT,"al","AL")'="ALL"
...I 'IBCNT,IBALL="ALL" D Q
....S IBCNT="ALL",IBTYP=0
....F S IBTYP=$O(^IBE(355.31,IBTYP)) Q:'IBTYP D
.....I OPTN="D" D Q
......I $D(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)) S IBTYP(IBTYP)=""
.....I $$WARN1(IBTYP) S IBTYP(IBTYP)=""
...S DIC="^IBE(355.31,",DIC(0)="EMQ",X=IBALL D ^DIC
...I Y<0 Q:'$$QUIT() S (DONE,DONE1)=1,IBCNT="" K IBTYP Q
...I $D(IBTYP(+Y)) W !,"This category already selected." Q
...S IBTYP=+Y I $$WARN1(IBTYP) S IBTYP(IBTYP)="",IBCNT=IBCNT+1
..;
..I $O(IBTYP(""))="" S (DONE,DONE1)=1 Q
..;
..I IBALL="ALL",OPTN="D" D DELETE(IBALL,IBEDT) Q
..;
..S IBTYP=""
..F S IBTYP=$O(IBTYP(IBTYP)) Q:IBTYP="" D Q:DONE1!(OPTN<0)
...K ^TMP($J,"IBCAT")
...;IB*2.0*664/TAZ - Display the proper date to be filed.
...W !!,"Effective Date: ",$$DAT1^IBOUTL(IBEDT1)," Coverage Category: ",$P($G(^IBE(355.31,+IBTYP,0)),U)
...S OPTN="",DA=$O(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT,""))
...;/IB*2.0*631 - vd - Added some new prompting and deleting capabilities below, for US4555.
...I 'DA S OPTN="E"
...I IBALL'="ALL",OPTN="" S OPTN=$$ASK(1) Q:(OPTN<0) I OPTN="D" D Q
....D DELETE(IBALL,IBEDT,DA)
...I DA'="" D SAVE^IBCNSJ52(DA) W !,"Editing existing record.",!
...I DA="" D Q:'DA ;Add a new record
....W ! S DIR(0)="Y",DIR("A",1)="A new record will be added for this EFFECTIVE DATE/coverage category."
....S DIR("A")="Is this OK",DIR("B")="YES" D ^DIR K DIR
....I Y'=1 S:$$QUIT() (DONE,DONE1)=1 Q
....K DO,DD
....;IB*2.0*664/TAZ - File the proper (precise) date
....S DIC="^IBA(355.32,",DIC(0)="L",X=IBCPOL,DIC("DR")=".02////"_IBTYP_";.03////"_IBEDT1_";.04////1" D FILE^DICN
....S DA=$S(Y>0:+Y,1:0)
....W:DA !,"New record added.",!
...;
...S IBCOV=DA
...;
...L +^IBA(355.32,IBCOV):5 I '$T D LOCKED^IBTRCD1 Q
...S DIE="^IBA(355.32,",DR=".04;S Y=$S(X'>1:"""",1:2);2"
...D ^DIE S IBOUT=$D(Y)
...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
...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
...L -^IBA(355.32,IBCOV)
...;
...I IBOUT,$$QUIT() S (DONE,DONE1)=1
..K IBTYP S IBCNT=0
;
EDCOVEX S VALMBCK="R"
K ^TMP($J,"IBCOV")
Q
;
QUIT() ; Quit coverage limitation loop
N DIR,Y
S DIR(0)="Y",DIR("A")="Do you want to exit this function now",DIR("B")="YES" D ^DIR
Q Y
;
COVDTH ; Help text for selecting effective date on coverage add/edit
N Z,Z0,ZX,CT
D HELP^%DTC
I $O(^IBA(355.32,"APCD",IBCPOL,""))="" W !!,"No current dates on file for this plan." Q
W !!,"Current dates on file for this plan:"
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)=""
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)"
Q
;
COVTYPH ; Help text for selecting coverage category on coverage add/edit
N DIC
W !!,"Enter a coverage category to add/edit coverage limitations for.",!
S DIC="^IBE(355.31,",DIC(0)="M",X="?" D ^DIC
I '$G(IBCNT) W !,"Enter ALL to select all coverage categories."
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."
Q
;
WARN1(IBTYP) ; Warning if adding/editing an earlier effective date than latest one on file
N IB1,Y
S IB1=$O(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-9999999)),Y=1
I IB1'="",IB1<-IBEDT D
.W !
.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)_"."
.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"
.D ^DIR K DIR
.W !
Q (Y=1)
;
;/IB*2.0*631/vd - This section added (for US4555)
ASK(ALLENT) ; Does the user want to Edit or Delete the selected category(ies)?
; ALLENT - if set to 1, the user has selected a single entry
; - if set to anything other than 1, the user has selected 'all' entries.
;
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
S DIR(0)="SA^E:Edit;D:Delete",DIR("B")="E"
S DIR("A")="Do you want to Edit or Delete "_$S(ALLENT=1:"this entry",1:"entries")_"? "
S DIR("?")="If you wish to EDIT "_$S(ALLENT=1:"this entry",1:"entries")_" enter 'E'dit. To DELETE "_$S(ALLENT=1:"this entry",1:"entries")_" enter 'D'elete."
W ! D ^DIR
Q $S("^D^E^"[(U_Y_U):Y,1:-1)
;
;/IB*2.0*631/vd - This section added (for US4555)
DELETE(OPTALL,DDATE,IBREC) ; Delete specified Categories
; INPUT: OPTALL - This can be either a specified coverage category or 'ALL'
; DDATE - This is the selected effective date
; IBREC - This is the record to be deleted for the selected coverage category, or it is NULL for 'ALL'
N DELOP,IBREF,IBTY,TMP
I OPTALL="ALL" D Q
. ;
. W !!,"The effective date of ",$$DAT1^IBOUTL(IBEDT)," will be deleted for the following coverage"
. W !,"categories:"
. S IBTY="" F S IBTY=$O(IBTYP(IBTY)) Q:IBTY="" D
. . W !?5,$$GET1^DIQ(355.31,IBTY_",",.01) ; Display a Coverage Category.
. . S IBREF=$O(^IBA(355.32,"APCD",+IBCPOL,IBTY,(-1*DDATE),""))
. . S TMP(+IBCPOL,IBTY)=IBREF
. ;
. I '$D(TMP) D Q ; Only display if no Coverage Categories were found.
. . W ! S DIR("A",1)="No Coverage Categories found for requested effective date."
. . S DIR(0)="FAO",DIR("A")="Press RETURN to continue..." D ^DIR K DIR
. ;
. S DELOP=$$DELASK(DDATE) Q:'DELOP
. ; Loop thru the TMP local global for IBCPOL and DELETE the list of related COVERAGE CATEGORIES.
. S IBTY="" F S IBTY=$O(TMP(IBCPOL,IBTY)) Q:IBTY="" D
. . S IBREF=TMP(IBCPOL,IBTY)
. . D DELETIT(IBREF)
. . D DELMSG(DDATE,IBTY)
. K TMP
;
S DELOP=$$DELASK(DDATE) Q:'DELOP
D DELETIT(IBREC) ; Delete the selected coverage category
D DELMSG(DDATE,IBTYP) ; Report to user that category was deleted
Q
;
;/IB*2.0*631/vd - This section added (for US4555)
DELASK(DDATE) ; Prompt the user for DELETE question.
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete the effective date of "_$$DAT1^IBOUTL(DDATE)
S DIR("B")="N" D ^DIR K DIR W !
Q Y
;
;/IB*2.0*631/vd - This section added (for US4555)
DELMSG(DDATE,CAT) ; Display message that a Coverage Category has been deleted.
N CATNAM
S CATNAM=$$GET1^DIQ(355.31,CAT_",",.01)
W !,$$DAT1^IBOUTL(IBEDT)," for ",CATNAM," has been deleted."
Q
;
;/IB*2.0*631/vd - This section added (for US4555)
DELETIT(DA) ; Delete a coverage category for a selected date.
; DA - passed in IEN (was variable IBREC)
N DIDEL,DIK
S DIK="^IBA(355.32,",DIDEL=355.32 D ^DIK ;Delete coverage category record for the specific date.
K DIK
Q
;
PRECISE(X1,X2) ;Check to make sure the date entered is a precise date.
N %Y
D ^%DTC
Q %Y
;
EXISTS(IBCPOL,IBEDT) ; Check to see if there are any categories for the selected policy and date.
N EXISTS,IBTYP
S (EXISTS,IBTYP)=0
F S IBTYP=$O(^IBE(355.31,IBTYP)) Q:'IBTYP D Q:+EXISTS
.I $D(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)) S EXISTS=1 ; Found a category with this date...so able to ask 'Edit or Delete' question.
Q EXISTS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ51 10300 printed Oct 16, 2024@18:18:01 Page 2
IBCNSJ51 ;ALB/TMP - INSURANCE PLAN MAINTENANCE ACTION PROCESSING (continued); 15-AUG-95
+1 ;;2.0;INTEGRATED BILLING;**43,631,664**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EDCOV ; Add/edit limitations of coverage for a plan in IBCPOL
+1 ;/IB*2.0*631/vd - Added the variables IBALL and OPTN (for US4555)
+2 NEW DIC,DIE,DR,DONE,DONE1,IB1,IBALL,IBCOV,IBCNT,IBEDT,IBEDT1,IBOK,IBOUT,IBQUIT,IBTYP,OPTN,Z
+3 if '$GET(IBCPOL)
GOTO EDCOVEX
+4 DO FULL^VALM1
+5 ;
+6 SET (DONE,OPTN)=0
+7 SET DONE=0
+8 ; Effective date selection
FOR
Begin DoDot:1
+9 KILL DIR
+10 WRITE !
+11 SET DIR(0)="DO"
SET DIR("A")="Select EFFECTIVE DATE"
SET DIR("?")="^D COVDTH^IBCNSJ51"
if $DATA(IBEDT)
SET DIR("B")=$$DAT1^IBOUTL(IBEDT)
+12 DO ^DIR
if $DATA(Y(0))
WRITE " ",Y(0)
KILL DIR
+13 IF $DATA(DIRUT)
SET DONE=1
QUIT
+14 ;IB*2.0*664/TAZ - Initialize IBEDT1 to equal the selected Effective Date.
+15 SET (IBEDT,IBEDT1)=Y\1
SET IBCNT=0
+16 KILL IBTYP
+17 ;IB*2.0*664/TAZ - Check for imprecise date and prompt for a precise date for filing.
+18 ; Reset DONE to not Quit out totally on BAD DATES.
IF '$$PRECISE(DT,IBEDT)
Begin DoDot:2
+19 ; Check to see if there are any categories for the selected policy and imprecise date.
IF $$EXISTS(IBCPOL,IBEDT)
Begin DoDot:3
+20 SET IBALL="ALL"
SET DA=""
+21 KILL IBTYP
SET IBTYP=0
+22 FOR
SET IBTYP=$ORDER(^IBE(355.31,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:4
+23 IF $DATA(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT))
SET IBTYP(IBTYP)=""
End DoDot:4
+24 ; Check if the existing categories should be deleted for the imprecise date.
DO DELETE(IBALL,IBEDT,DA)
+25 SET DONE=1
+26 QUIT
End DoDot:3
QUIT
+27 ;
+28 SET DIR("A")="Enter a new precise EFFECTIVE DATE"
+29 SET DIR("A",1)="You have entered an imprecise date. You must enter a precise date to"
+30 SET DIR("A",2)="edit/add a Coverage Limitation."
+31 SET DIR("A",4)=""
+32 SET DIR(0)="D^::EX"
+33 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET DONE=1
QUIT
+34 SET (IBEDT,IBEDT1)=Y\1
End DoDot:2
IF DONE
SET DONE=0
QUIT
+35 ;
+36 SET DONE1=0
+37 ; Coverage category type selection
FOR
Begin DoDot:2
+38 KILL DIR
+39 WRITE !
+40 SET DIR(0)="F"_$SELECT(IBCNT:"O",1:"")_"^1:30"
SET DIR("A")="Select "_$SELECT(IBCNT:"another ",1:"")_"coverage category -OR- "_$SELECT(IBCNT:"Press ENTER if selection is complete",1:"'ALL' to select all coverage categories")
+41 SET DIR("?")="^D COVTYPH^IBCNSJ51"
+42 DO ^DIR
KILL DIR
+43 IF $DATA(DUOUT)!$DATA(DTOUT)
SET DONE1=1
QUIT
+44 ;
+45 ;/IB*2.0*631 - vd - Preserving the 'Y' variable in the IBALL variable so it won't get stepped on.
SET IBALL=Y
+46 ;/IB*2.0*631 - vd - Added some new prompting and deleting capabilities below.
+47 IF IBALL="ALL"
Begin DoDot:3
+48 ; Default OPTN to EDIT...if no categories exist for date...we just want to ADD. No need to ask 'Edit or Delete' question.
SET OPTN="E"
SET IBTYP=0
+49 ; Check to see if there are existing categories for the date entered.
IF $$EXISTS(IBCPOL,IBEDT)
SET OPTN=""
+50 IF OPTN=""
SET OPTN=$$ASK(0)
if (OPTN<0)
QUIT
End DoDot:3
+51 IF IBALL'=""
Begin DoDot:3
+52 IF 'IBCNT
IF IBALL="ALL"
Begin DoDot:4
+53 SET IBCNT="ALL"
SET IBTYP=0
+54 FOR
SET IBTYP=$ORDER(^IBE(355.31,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:5
+55 IF OPTN="D"
Begin DoDot:6
+56 IF $DATA(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT))
SET IBTYP(IBTYP)=""
End DoDot:6
QUIT
+57 IF $$WARN1(IBTYP)
SET IBTYP(IBTYP)=""
End DoDot:5
End DoDot:4
QUIT
+58 SET DIC="^IBE(355.31,"
SET DIC(0)="EMQ"
SET X=IBALL
DO ^DIC
+59 IF Y<0
if '$$QUIT()
QUIT
SET (DONE,DONE1)=1
SET IBCNT=""
KILL IBTYP
QUIT
+60 IF $DATA(IBTYP(+Y))
WRITE !,"This category already selected."
QUIT
+61 SET IBTYP=+Y
IF $$WARN1(IBTYP)
SET IBTYP(IBTYP)=""
SET IBCNT=IBCNT+1
End DoDot:3
if $TRANSLATE(IBCNT,"al","AL")'="ALL"
QUIT
+62 ;
+63 IF $ORDER(IBTYP(""))=""
SET (DONE,DONE1)=1
QUIT
+64 ;
+65 IF IBALL="ALL"
IF OPTN="D"
DO DELETE(IBALL,IBEDT)
QUIT
+66 ;
+67 SET IBTYP=""
+68 FOR
SET IBTYP=$ORDER(IBTYP(IBTYP))
if IBTYP=""
QUIT
Begin DoDot:3
+69 KILL ^TMP($JOB,"IBCAT")
+70 ;IB*2.0*664/TAZ - Display the proper date to be filed.
+71 WRITE !!,"Effective Date: ",$$DAT1^IBOUTL(IBEDT1)," Coverage Category: ",$PIECE($GET(^IBE(355.31,+IBTYP,0)),U)
+72 SET OPTN=""
SET DA=$ORDER(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT,""))
+73 ;/IB*2.0*631 - vd - Added some new prompting and deleting capabilities below, for US4555.
+74 IF 'DA
SET OPTN="E"
+75 IF IBALL'="ALL"
IF OPTN=""
SET OPTN=$$ASK(1)
if (OPTN<0)
QUIT
IF OPTN="D"
Begin DoDot:4
+76 DO DELETE(IBALL,IBEDT,DA)
End DoDot:4
QUIT
+77 IF DA'=""
DO SAVE^IBCNSJ52(DA)
WRITE !,"Editing existing record.",!
+78 ;Add a new record
IF DA=""
Begin DoDot:4
+79 WRITE !
SET DIR(0)="Y"
SET DIR("A",1)="A new record will be added for this EFFECTIVE DATE/coverage category."
+80 SET DIR("A")="Is this OK"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+81 IF Y'=1
if $$QUIT()
SET (DONE,DONE1)=1
QUIT
+82 KILL DO,DD
+83 ;IB*2.0*664/TAZ - File the proper (precise) date
+84 SET DIC="^IBA(355.32,"
SET DIC(0)="L"
SET X=IBCPOL
SET DIC("DR")=".02////"_IBTYP_";.03////"_IBEDT1_";.04////1"
DO FILE^DICN
+85 SET DA=$SELECT(Y>0:+Y,1:0)
+86 if DA
WRITE !,"New record added.",!
End DoDot:4
if 'DA
QUIT
+87 ;
+88 SET IBCOV=DA
+89 ;
+90 LOCK +^IBA(355.32,IBCOV):5
IF '$TEST
DO LOCKED^IBTRCD1
QUIT
+91 SET DIE="^IBA(355.32,"
SET DR=".04;S Y=$S(X'>1:"""",1:2);2"
+92 DO ^DIE
SET IBOUT=$DATA(Y)
+93 ;Delete comments
IF $PIECE($GET(^IBA(355.32,IBCOV,0)),U,4)'>1
IF $ORDER(^(2,0))
SET Z=0
FOR
SET Z=$ORDER(^IBA(355.32,IBCOV,2,Z))
if 'Z
QUIT
SET DIK="^IBA(355.32,"_IBCOV_",2,"
SET DA(1)=IBCOV
SET DA=Z
DO ^DIK
+94 ;Update user who edited entry
IF $$DIFFLIM^IBCNSJ52(IBCOV)
SET DIE="^IBA(355.32,"
SET DA=IBCOV
SET DR="1.03///NOW;1.04////^S X=DUZ"
DO ^DIE
+95 LOCK -^IBA(355.32,IBCOV)
+96 ;
+97 IF IBOUT
IF $$QUIT()
SET (DONE,DONE1)=1
End DoDot:3
if DONE1!(OPTN<0)
QUIT
+98 KILL IBTYP
SET IBCNT=0
End DoDot:2
if DONE1!(OPTN<0)
QUIT
End DoDot:1
if DONE!(OPTN<0)
QUIT
+99 ;
EDCOVEX SET VALMBCK="R"
+1 KILL ^TMP($JOB,"IBCOV")
+2 QUIT
+3 ;
QUIT() ; Quit coverage limitation loop
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to exit this function now"
SET DIR("B")="YES"
DO ^DIR
+3 QUIT Y
+4 ;
COVDTH ; Help text for selecting effective date on coverage add/edit
+1 NEW Z,Z0,ZX,CT
+2 DO HELP^%DTC
+3 IF $ORDER(^IBA(355.32,"APCD",IBCPOL,""))=""
WRITE !!,"No current dates on file for this plan."
QUIT
+4 WRITE !!,"Current dates on file for this plan:"
+5 SET Z=""
FOR
SET Z=$ORDER(^IBA(355.32,"APCD",IBCPOL,Z))
if 'Z
QUIT
SET Z0=""
FOR
SET Z0=$ORDER(^IBA(355.32,"APCD",IBCPOL,Z,Z0))
if 'Z0
QUIT
SET ZX(Z0,Z)=""
+6 SET Z=""
FOR
SET Z=$ORDER(ZX(Z))
if 'Z
QUIT
WRITE !,?3,$$DAT1^IBOUTL(-Z)," -"
SET Z0=""
SET CT=0
FOR
SET Z0=$ORDER(ZX(Z,Z0))
if 'Z0!(CT>3)
QUIT
SET CT=CT+1
WRITE " ",$PIECE($GET(^IBE(355.31,Z0,0)),U)
if CT=4&($ORDER(ZX(Z,Z0))'="")
WRITE " (and more)"
+7 QUIT
+8 ;
COVTYPH ; Help text for selecting coverage category on coverage add/edit
+1 NEW DIC
+2 WRITE !!,"Enter a coverage category to add/edit coverage limitations for.",!
+3 SET DIC="^IBE(355.31,"
SET DIC(0)="M"
SET X="?"
DO ^DIC
+4 IF '$GET(IBCNT)
WRITE !,"Enter ALL to select all coverage categories."
+5 WRITE !,"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."
+6 QUIT
+7 ;
WARN1(IBTYP) ; Warning if adding/editing an earlier effective date than latest one on file
+1 NEW IB1,Y
+2 SET IB1=$ORDER(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-9999999))
SET Y=1
+3 IF IB1'=""
IF IB1<-IBEDT
Begin DoDot:1
+4 WRITE !
+5 SET DIR(0)="Y"
SET DIR("A",1)="An effective date later than the one you selected"
SET DIR("A",2)="already exists for "_$PIECE($GET(^IBE(355.31,IBTYP,0)),U)_"."
+6 SET DIR("A")=" Are you sure you want to "_$SELECT($DATA(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)):"edit",1:"add")_" this earlier date for the category"
SET DIR("B")="NO"
+7 DO ^DIR
KILL DIR
+8 WRITE !
End DoDot:1
+9 QUIT (Y=1)
+10 ;
+11 ;/IB*2.0*631/vd - This section added (for US4555)
ASK(ALLENT) ; Does the user want to Edit or Delete the selected category(ies)?
+1 ; ALLENT - if set to 1, the user has selected a single entry
+2 ; - if set to anything other than 1, the user has selected 'all' entries.
+3 ;
+4 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+5 SET DIR(0)="SA^E:Edit;D:Delete"
SET DIR("B")="E"
+6 SET DIR("A")="Do you want to Edit or Delete "_$SELECT(ALLENT=1:"this entry",1:"entries")_"? "
+7 SET DIR("?")="If you wish to EDIT "_$SELECT(ALLENT=1:"this entry",1:"entries")_" enter 'E'dit. To DELETE "_$SELECT(ALLENT=1:"this entry",1:"entries")_" enter 'D'elete."
+8 WRITE !
DO ^DIR
+9 QUIT $SELECT("^D^E^"[(U_Y_U):Y,1:-1)
+10 ;
+11 ;/IB*2.0*631/vd - This section added (for US4555)
DELETE(OPTALL,DDATE,IBREC) ; Delete specified Categories
+1 ; INPUT: OPTALL - This can be either a specified coverage category or 'ALL'
+2 ; DDATE - This is the selected effective date
+3 ; IBREC - This is the record to be deleted for the selected coverage category, or it is NULL for 'ALL'
+4 NEW DELOP,IBREF,IBTY,TMP
+5 IF OPTALL="ALL"
Begin DoDot:1
+6 ;
+7 WRITE !!,"The effective date of ",$$DAT1^IBOUTL(IBEDT)," will be deleted for the following coverage"
+8 WRITE !,"categories:"
+9 SET IBTY=""
FOR
SET IBTY=$ORDER(IBTYP(IBTY))
if IBTY=""
QUIT
Begin DoDot:2
+10 ; Display a Coverage Category.
WRITE !?5,$$GET1^DIQ(355.31,IBTY_",",.01)
+11 SET IBREF=$ORDER(^IBA(355.32,"APCD",+IBCPOL,IBTY,(-1*DDATE),""))
+12 SET TMP(+IBCPOL,IBTY)=IBREF
End DoDot:2
+13 ;
+14 ; Only display if no Coverage Categories were found.
IF '$DATA(TMP)
Begin DoDot:2
+15 WRITE !
SET DIR("A",1)="No Coverage Categories found for requested effective date."
+16 SET DIR(0)="FAO"
SET DIR("A")="Press RETURN to continue..."
DO ^DIR
KILL DIR
End DoDot:2
QUIT
+17 ;
+18 SET DELOP=$$DELASK(DDATE)
if 'DELOP
QUIT
+19 ; Loop thru the TMP local global for IBCPOL and DELETE the list of related COVERAGE CATEGORIES.
+20 SET IBTY=""
FOR
SET IBTY=$ORDER(TMP(IBCPOL,IBTY))
if IBTY=""
QUIT
Begin DoDot:2
+21 SET IBREF=TMP(IBCPOL,IBTY)
+22 DO DELETIT(IBREF)
+23 DO DELMSG(DDATE,IBTY)
End DoDot:2
+24 KILL TMP
End DoDot:1
QUIT
+25 ;
+26 SET DELOP=$$DELASK(DDATE)
if 'DELOP
QUIT
+27 ; Delete the selected coverage category
DO DELETIT(IBREC)
+28 ; Report to user that category was deleted
DO DELMSG(DDATE,IBTYP)
+29 QUIT
+30 ;
+31 ;/IB*2.0*631/vd - This section added (for US4555)
DELASK(DDATE) ; Prompt the user for DELETE question.
+1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete the effective date of "_$$DAT1^IBOUTL(DDATE)
+3 SET DIR("B")="N"
DO ^DIR
KILL DIR
WRITE !
+4 QUIT Y
+5 ;
+6 ;/IB*2.0*631/vd - This section added (for US4555)
DELMSG(DDATE,CAT) ; Display message that a Coverage Category has been deleted.
+1 NEW CATNAM
+2 SET CATNAM=$$GET1^DIQ(355.31,CAT_",",.01)
+3 WRITE !,$$DAT1^IBOUTL(IBEDT)," for ",CATNAM," has been deleted."
+4 QUIT
+5 ;
+6 ;/IB*2.0*631/vd - This section added (for US4555)
DELETIT(DA) ; Delete a coverage category for a selected date.
+1 ; DA - passed in IEN (was variable IBREC)
+2 NEW DIDEL,DIK
+3 ;Delete coverage category record for the specific date.
SET DIK="^IBA(355.32,"
SET DIDEL=355.32
DO ^DIK
+4 KILL DIK
+5 QUIT
+6 ;
PRECISE(X1,X2) ;Check to make sure the date entered is a precise date.
+1 NEW %Y
+2 DO ^%DTC
+3 QUIT %Y
+4 ;
EXISTS(IBCPOL,IBEDT) ; Check to see if there are any categories for the selected policy and date.
+1 NEW EXISTS,IBTYP
+2 SET (EXISTS,IBTYP)=0
+3 FOR
SET IBTYP=$ORDER(^IBE(355.31,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:1
+4 ; Found a category with this date...so able to ask 'Edit or Delete' question.
IF $DATA(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT))
SET EXISTS=1
End DoDot:1
if +EXISTS
QUIT
+5 QUIT EXISTS
