IBCNBCD2 ;ALB/AWC - MCCF FY14 Display Group Plan Coverage Limitations from Insurance Buffer entry ;25 Feb 2015
;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
;;Per VA Directive 6402, this routine should not be modified.
;
; Input Parameters:
; See routine IBCNBCD1
;
COVLIM(IBBUFDA,IBGRPDA,IBCSAV,IBQ,IBERR) ; Coverage Limitations entry point. - Called from routine ACCOV^IBCNBAA
N IBGSAV,IBSYS,IBDATE,IBDTL,IBFOUND,IBDATA,IBEDIT,IBOUT,IBPLAN,IBYES,IBTXT,IBN,DTOUT
S IBN=0,IBTXT=""
;
; -- **** CAUTION DO NOT KILL ****
N IBSYS S IBSYS=$NA(^IBA(355.32)) ; -- **** VistA System Coverage Limitation Global ****
; -- **** CAUTION DO NOT KILL ****
;
;
F S IBQ=$$ASKREV() Q:IBQ'=1!($D(DTOUT)) D Q:$D(IBERR)
. ;
. ; -- display a list of coverage limitations years for the group policy
. D CVDTS(IBGRPDA,.IBDTL)
. ;
. ; -- prompt user to select coverage limitation year
. S IBDATE=$$ASKYR() Q:$E(IBDATE)=U!($D(DTOUT))
. ;
. ; -- get data for selected coverage limitation year
. S IBFOUND=$$CVDATA(IBDATE,.IBDTL,.IBGSAV,.IBSYS,.IBDATA,.IBERR) Q:$D(IBERR)
. ;
. ; -- user entered a new date not found in the display list
. I 'IBFOUND D Q:'IBYES!('IBFOUND)!($D(IBERR))
. . ;
. . ; -- ask user to create new benifit year
. . S IBYES=$$CREYR(.IBDATE) Q:'IBYES
. . ;
. . ; -- create a new record entry
. . D CVDLC(IBGRPDA,IBDATE,.IBDTL,.IBERR) Q:$D(IBERR)
. . ;
. . ; -- get data for newly created record
. . S IBFOUND=$$CVDATA(IBDATE,.IBDTL,.IBGSAV,.IBSYS,.IBDATA,.IBERR) Q:$D(IBERR)
. . S IBN=1
. . ;
. ;
. ; -- get coverage plans and display coverage limitations for selected year
. D CVPLAN(.IBPLAN) S IBOUT=$$CVDISP^IBCNBCD3(.IBDATA,.IBPLAN) Q:IBOUT
. ;
. ; -- edit coverage limitations
. S IBTXT=$S(IBN:"the NEW",1:"existing")
. S IBEDIT=$$EDTYR(IBDATE,IBTXT) I IBEDIT D CVEDIT(IBGRPDA,.IBGSAV,.IBSYS,IBDATE,.IBCSAV,.IBDATA,.IBERR)
. S IBN=0
. ;
D CVOUT(.IBDATA)
Q
;
CVDTS(IBGRPDA,IBDTL) ; Display a list of Coverage Limitations Years to select
N IBI,IBIEN,IBDT,IBXDT,IBIDT,IBRET
;
S IBDTL=$NA(^TMP("IBCNBCD2 CVDTS DATES",$J))
K @IBDTL
;
F IBI=0:0 S IBI=$O(^IBA(355.32,"APCD",IBGRPDA,IBI)) Q:IBI'>0 D
. S IBDT="" F S IBDT=$O(^IBA(355.32,"APCD",IBGRPDA,IBI,IBDT)) Q:IBDT="" D
. . S IBIEN=$O(^IBA(355.32,"APCD",IBGRPDA,IBI,IBDT,0))
. . S IBIDT=-(IBDT) D DT^DILF("E",IBIDT,.IBRET) S IBXDT=$G(IBRET(0))
. . ;
. . ; -- put dates in assending order - example: S @IBDTL@(nncyyddmm,IEN)=mmm dd, yyyy
. . I IBXDT["JAN" S @IBDTL@(11_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["FEB" S @IBDTL@(12_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["MAR" S @IBDTL@(13_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["APR" S @IBDTL@(14_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["MAY" S @IBDTL@(15_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["JUN" S @IBDTL@(16_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["JUL" S @IBDTL@(17_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["AUG" S @IBDTL@(18_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["SEP" S @IBDTL@(19_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["OCT" S @IBDTL@(20_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["NOV" S @IBDTL@(21_IBIDT,IBIEN)=IBXDT Q
. . I IBXDT["DEC" S @IBDTL@(22_IBIDT,IBIEN)=IBXDT
;
W !!,"Coverage Date:",!
F IBDT=0:0 S IBDT=$O(@IBDTL@(IBDT)) Q:IBDT'>0 S IBIEN=$O(@IBDTL@(IBDT,0)) W ?2,@IBDTL@(IBDT,IBIEN),!
Q
CVDATA(IBDATE,IBDTL,IBGSAV,IBSYS,IBDATA,IBERR) ; Get data for the selected year
N IBI,IBJ,IBHOLD,IBFLDS,IBCDA,IBIEN,IBPLN,IBDAT,IBLOCK
S IBDATA=$NA(^TMP("IBCNBCD2 CVDATA DATA",$J))
S IBGSAV=$NA(^TMP("IBCNBCD2 IB CV GSAV",$J))
K @IBDATA,@IBGSAV
; ;
S IBDAT=0,IBFLDS=".02;.03;.04"
;
F IBI=0:0 S IBI=$O(@IBDTL@(IBI)) Q:IBI'>0 I $E(IBI,3,$L(IBI))=+IBDATE D Q:$D(IBERR)
. F IBIEN=0:0 S IBIEN=$O(@IBDTL@(IBI,IBIEN)) Q:IBIEN'>0 D Q:$D(IBERR)
. . ;
. . S IBHOLD=$NA(^TMP("IBCNBCD2 CVDATA HOLD",$J))
. . K @IBHOLD
. . D GETS^DIQ(355.32,IBIEN_",",.IBFLDS,"IE",.IBHOLD,"IBERR") I $D(IBERR) W !,"***Error...CVDATA^IBCNBCD2 Cannot retrieve Coverage Limitations data fields." D PAUSE^VALM1 Q
. . S IBPLN=@IBHOLD@(355.32,IBIEN_",",.02,"E")
. . M @IBDATA@(IBPLN)=@IBHOLD@(355.32,IBIEN_",")
. . S @IBDATA@(IBPLN)=IBIEN ; -- top level so set it to the IEN
. . S IBLOCK=$$CVLOCK(IBIEN,.IBSYS) I 'IBLOCK S IBERR=1 Q ; -- lock the record
. . ;
. . ; -- save off the system global data
. . S @IBGSAV@(IBIEN,0)=$G(^IBA(355.32,IBIEN,0))
. . S @IBGSAV@(IBIEN,1)=$G(^IBA(355.32,IBIEN,1))
. . S @IBGSAV@(IBIEN,2,0)=$G(^IBA(355.32,IBIEN,2,0))
. . ;
. . F IBJ=0:0 S IBJ=$O(^IBA(355.32,IBIEN,2,IBJ)) Q:IBJ'>0 D
. . . S @IBDATA@(IBPLN,"COMM",IBJ)=^IBA(355.32,IBIEN,2,IBJ,0)
. . . S @IBGSAV@(IBIEN,2,IBJ,0)=$G(^IBA(355.32,IBIEN,2,IBJ,0)) ; -- save off the system global comments data
;
I $D(@IBDATA) S IBDAT=1
Q IBDAT
;
CVPLAN(IBPLAN) ; Display/Edit Coverage Limitations for selected date
N IBI,IBJ
S IBPLAN=$NA(^TMP("IBCNBCD2 CVDSEL PLAN COV",$J))
K @IBPLAN
;
S IBI="" F S IBI=$O(^IBE(355.31,"B",IBI)) Q:IBI']"" S IBJ=$O(^IBE(355.31,"B",IBI,0)) S @IBPLAN@(IBI,IBJ)=""
Q
;
CVLOCK(IBIEN,IBSYS) ; Lock the Coverage Limitations records
N IBOUT
S IBOUT=1
L +@IBSYS@(IBIEN):5 I '$T S IBOUT=0 D CVLKD
Q IBOUT
;
CVEDIT(IBGRPDA,IBGSAV,IBSYS,IBDATE,IBCSAV,IBDATA,IBERR) ; Edit Coverage Limitations via Input Template 355.32
N IBI,IBIEN,IBDR,IBDIF,IBSAV,IBADD,IBOUT,IBPLC
N IBIP,IBOP,IBPH,IBDN,IBMH,IBLT
N IBCI,IBCO,IBCP,IBCD,IBCM,IBCL
;
; -- check if data for the coverage categories
S (IBOP,IBIP,IBPH,IBLT,IBDN,IBMH)="" ; -- DA's of the IBDATA global holding the record location
S (IBCI,IBCO,IBCP,IBCD,IBCM,IBCL)="" ; -- pointers to the PLAN LIMITATION CATEGORY FILE (#355.31)
;
; -- get plan limitation categories ien'S
S IBPLC=$NA(^TMP("IBCNBCD2 IB PLAN LIM CATEGORIES",$J))
K @IBPLC
D LIST^DIC(355.31,,"@;.01E",,,,,"B",,,.IBPLC,"IBERR") I $D(IBERR) W !,"*** Error...CVEDIT^IBCNBCD2 Cannot access Plan Limitations Category File!" D PAUSE^VALM1 Q
F IBI=0:0 S IBI=$O(@IBPLC@("ID",IBI)) Q:IBI'>0 D
. I @IBPLC@("ID",IBI,.01)="DENTAL" S IBCD=@IBPLC@(2,IBI) Q
. I @IBPLC@("ID",IBI,.01)="OUTPATIENT" S IBCO=@IBPLC@(2,IBI) Q
. I @IBPLC@("ID",IBI,.01)="PHARMACY" S IBCP=@IBPLC@(2,IBI) Q
. I @IBPLC@("ID",IBI,.01)="INPATIENT" S IBCI=@IBPLC@(2,IBI) Q
. I @IBPLC@("ID",IBI,.01)="MENTAL HEALTH" S IBCM=@IBPLC@(2,IBI) Q
. I @IBPLC@("ID",IBI,.01)="LONG TERM CARE" S IBCL=@IBPLC@(2,IBI)
;
; -- check if our data list contain plan coverage limitations
S IBI=""
F S IBI=$O(@IBDATA@(IBI)) Q:IBI']"" D
. I IBI="INPATIENT" S IBIP=IBI Q
. I IBI="OUTPATIENT" S IBOP=IBI Q
. I IBI="PHARMACY" S IBPH=IBI Q
. I IBI="DENTAL" S IBDN=IBI Q
. I IBI="MENTAL HEALTH" S IBMH=IBI Q
. I IBI="LONG TERM CARE" S IBLT=IBI
;
;
W !!,"---------------------- EDIT COVERAGE LIMITATIONS INFORMATION -----------------------",!
;
; -- inpatient
I IBIP]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. S IBOUT=0,IBIEN=$G(@IBDATA@(IBIP)),IBDR="[IBCNBC CV IP EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBIP,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBIP']"" S IBADD=$$ASKADD("INPATIENT",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCI,IBDATE,.IBERR)
;
; -- outpatient
I IBOP]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. W ! S IBOUT=0,IBIEN=$G(@IBDATA@(IBOP)),IBDR="[IBCNBC CV OP EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBOP,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBOP']"" S IBADD=$$ASKADD("OUTPATIENT",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCO,IBDATE,.IBERR)
;
; -- pharmacy
I IBPH]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. W ! S IBOUT=0,IBIEN=$G(@IBDATA@(IBPH)),IBDR="[IBCNBC CV PH EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBPH,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBPH']"" S IBADD=$$ASKADD("PHARMACY",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCP,IBDATE,.IBERR)
;
; -- dental
I IBDN]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. W ! S IBOUT=0,IBIEN=$G(@IBDATA@(IBDN)),IBDR="[IBCNBC CV DN EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBDN,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBDN']"" S IBADD=$$ASKADD("DENTAL",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCD,IBDATE,.IBERR)
;
; -- mental health
I IBMH]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. W ! S IBOUT=0,IBIEN=$G(@IBDATA@(IBMH)),IBDR="[IBCNBC CV MH EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBMH,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBMH']"" S IBADD=$$ASKADD("MENTAL HEALTH",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCM,IBDATE,.IBERR)
;
; -- long term
I IBLT]"" D Q:IBOUT!($D(IBERR))!($D(DTOUT))
. W ! S IBOUT=0,IBIEN=$G(@IBDATA@(IBLT)),IBDR="[IBCNBC CV LT EDIT]"
. D EDTREC(IBIEN,IBDR) I $G(Y(0))="AUDIT" S IBOUT=1 Q
. S IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN),IBSAV=1
. I IBDIF S IBSAV=$$CVASK()
. I (IBDIF&('IBSAV))!($D(DTOUT)) D CVUNDO(IBIEN,IBLT,.IBSYS,.IBGSAV,.IBDATA,.IBERR) Q
. I (IBDIF&(IBSAV))&('$D(DTOUT)) S IBCSAV=1
I IBLT']"" S IBADD=$$ASKADD("LONG TERM",IBDATE) Q:IBADD=U I IBADD Q:'$$ADDCV(IBGRPDA,IBCL,IBDATE,.IBERR)
Q
;
CVUNDO(IBIEN,IBPL,IBSYS,IBGSAV,IBDATA,IBERR) ; - undo any coverage limitations edits
N X,Y,DA,DIC,DIK,IBI,IBJ,IBFLD,IBIENH,IBFDA
;
S IBFDA=$NA(^TMP("IBCNBCD2 CV EDIT FDA",$J))
K @IBFDA
;
; -- updo edits except for comments
F IBFLD=.01:0 S IBFLD=$O(@IBDATA@(IBPL,IBFLD)) Q:IBFLD'>0 S @IBFDA@(355.32,IBIEN_",",IBFLD)=$G(@IBDATA@(IBPL,IBFLD,"E"))
D FILE^DIE("E",.IBFDA,"IBERR") I $D(IBERR) S IBERR=1 W !,!,"*** Error...CVUNDO^IBCNBCD2 Cannot update Fields in the Coverage Limitations file! ",! K @IBFDA D PAUSE^VALM1
;
; -- put back any deleted comments
S IBJ=0
F IBI=0:0 S IBI=$O(@IBDATA@(IBPL,"COMM",IBI)) Q:IBI'>0 D Q:$D(IBERR)
. ;
. ; -- if comment subscript deleted - add the comment
. I $G(@IBSYS@(IBIEN,2,IBI,0))']"" D
. . S DIC="^IBA(355.32,"_IBIEN_",2,",DIC(0)="L",DA(1)=IBIEN,DA=IBI,X=@IBDATA@(IBPL,"COMM",IBI)
. . D FILE^DICN I '+Y S IBERR=1 W !,!,"*** Error...Cannot Add 'deleted' Comments in the Coverage Limitations file! ",! D PAUSE^VALM1
. . ;
. S IBJ=IBI
;
; -- delete any added comments
I +IBJ F IBI=IBJ:0 S IBI=$O(@IBSYS@(IBIEN,2,IBI)) Q:IBI'>0 D
. S DA(1)=IBIEN,DIK="^IBA(355.32,"_DA(1)_",2,",DA=IBI
. D ^DIK K DA,DIK
;
; -- put modified comments into fda array
S IBI=0,IBIENH=$G(@IBDATA@(IBPL))_","
F IBFLD=0:0 S IBFLD=$O(@IBDATA@(IBPL,"COMM",IBFLD)) Q:IBFLD'>0 D
. S IBIEN=IBFLD_","_IBIENH
. S @IBFDA@(355.321,IBIEN,0)=$G(@IBDATA@(IBPL,"COMM",IBFLD))
;
; -- undo any modified comments
I $D(@IBFDA)>9 D
. D FILE^DIE("E",.IBFDA,"IBERR")
. I $D(IBERR) W !,!,"*** Error...CVUNDO^IBCNBCD2 Cannot Put Original Comments in the Coverage Limitations file! ",! D PAUSE^VALM1
Q
;
CVDLC(IBGRPDA,IBDATE,IBDTL,IBERR) ; Create records for the new coverage limitation year
N IBI,IBPCC,IBIP,IBOP,IBPH,IBDN,IBMH,IBLT,IBIEN,IBDT,IBFDT
;
S IBDTL=$NA(^TMP("IBCNBCD2 CVDTS DATES",$J)),IBPCC=$NA(^TMP("IBCNBCD2 IB COVERAGE CAT",$J))
K @IBDTL,@IBPCC
;
; -- get coverage categories
D LIST^DIC(355.31,,"@;.01E",,,,,"B","",,.IBPCC,"IBERR") I $D(IBERR) W !,"Error...CVDLC^IBCNBCD2 Cannot access PLAN LIMITATION CATEGORY FILE!" D PAUSE^VALM1 Q
S (IBIP,IBOP,IBPH,IBDN,IBMH,IBLT)=0
F IBI=0:0 S IBI=$O(@IBPCC@("ID",IBI)) Q:IBI'>0 D
. I @IBPCC@("ID",IBI,.01)="INPATIENT" S IBIP=@IBPCC@(2,IBI) Q
. I @IBPCC@("ID",IBI,.01)="OUTPATIENT" S IBOP=@IBPCC@(2,IBI) Q
. I @IBPCC@("ID",IBI,.01)="PHARMACY" S IBPH=@IBPCC@(2,IBI) Q
. I @IBPCC@("ID",IBI,.01)="DENTAL" S IBDN=@IBPCC@(2,IBI) Q
. I @IBPCC@("ID",IBI,.01)="MENTAL HEALTH" S IBMH=@IBPCC@(2,IBI) Q
. I @IBPCC@("ID",IBI,.01)="LONG TERM CARE" S IBLT=@IBPCC@(2,IBI)
;
; -- add new records to the database
I IBIP&(IBOP)&(IBPH)&(IBDN)&(IBMH)&(IBLT) D Q:$D(IBERR)
. ;
. ; -- format the date
. S IBDT=+IBDATE D DT^DILF("E",IBDT,.IBRET) S IBFDT=$G(IBRET(0))
. ;
. ; -- load the coverage limitation date array with formatted date
. S IBIEN=$$ADDCV(IBGRPDA,IBIP,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
. S IBIEN=$$ADDCV(IBGRPDA,IBOP,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
. S IBIEN=$$ADDCV(IBGRPDA,IBPH,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
. S IBIEN=$$ADDCV(IBGRPDA,IBDN,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
. S IBIEN=$$ADDCV(IBGRPDA,IBMH,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
. S IBIEN=$$ADDCV(IBGRPDA,IBLT,IBDATE,.IBERR) Q:$D(IBERR) S @IBDTL@(99_IBDT,IBIEN)=IBFDT
Q
;
ADDCV(IBGRPDA,IBCAT,IBDATE,IBERR) ; Add new coverage limitation record
N X,Y,DA,DIC,IBIEN,IBA,IBB,IBC
S IBIEN=0,IBC="COVERED"
;
; -- retrieve the plan limitation category
S IBA=$$GET1^DIQ(355.31,IBCAT_",",.01,"E") I IBA']"" S IBERR=1 W !,"Error #1...ADDCV-IBCNBCD2 Cannot retrieve PLAN LIMITATION CATEGORY!" D PAUSE^VALM1 Q IBIEN
S IBB=$P(IBDATE,U,2)
;
; -- update plan coverage limitation file
S DIC="^IBA(355.32,",DIC(0)="L",X=IBGRPDA,DIC("DR")=".02///^S X=IBA;.03///^S X=IBB;.04///^S X=IBC"
D FILE^DICN S IBIEN=+Y I IBIEN<0!(IBIEN=0) S IBERR=1 W !,"Error #2...ADDCV-IBCNBCD2 Cannot add New Record to the PLAN COVERAGE LIMITATIONS FILE!" D PAUSE^VALM1
Q IBIEN
;
CVDIF(IBSYS,IBGSAV,IBIEN) ; -- check for any edits made to coverage limitations
N IBI,IBDIF
S IBDIF=0
I $G(@IBSYS@(IBIEN,0))'=$G(@IBGSAV@(IBIEN,0)) S IBDIF=1 Q IBDIF
I $G(@IBSYS@(IBIEN,1))'=$G(@IBGSAV@(IBIEN,1)) S IBDIF=1 Q IBDIF
I $G(@IBSYS@(IBIEN,2,0))'=$G(@IBGSAV@(IBIEN,2,0)) S IBDIF=1 Q IBDIF
I $D(@IBSYS@(IBIEN,2,0)) D
. F IBI=0:0 S IBI=$O(@IBSYS@(IBIEN,2,IBI)) Q:IBI'>0!(IBDIF) I $G(@IBSYS@(IBIEN,2,IBI,0))'=$G(@IBGSAV@(IBIEN,2,IBI,0)) S IBDIF=1 Q
Q IBDIF
;
EDTREC(IBIEN,IBDR) ; Edit Coverage Limitaitons
N DA,DR,DIE
S DA=IBIEN,DR=IBDR
S DIE="^IBA(355.32,",DIE("NO^")="BACKOUTOK"
D ^DIE
Q
;
CVOUT(IBDATA) ; -- unlock coverage limitations records
N IBI,IBIEN
I $D(IBDATA)>9 D
. S IBI=""
. F S IBI=$O(@IBDATA@(IBI)) Q:IBI']"" S IBIEN=$G(@IBDATA@(IBI)) L -@IBSYS@(IBIEN)
Q
;
CVLKD ; -- write locked message
W !!,"Sorry, another user currently editing this entry."
W !,"Try again in a few minutes."
D PAUSE^VALM1
Q
;
CVASK() ; Prompt to ask user to Save Changes
Q $E($$READ^IBCNBAA("YA^::E","Save Changes to Coverage Limitations File Y/N? ","No","Enter Yes or No to Save the Changes to the CV File <or> ^ to Quit"))
;
ASKREV() ; Prompt to review Coverage Limitations
Q $E($$READ^IBCNBAA("YA^::E","Do you want to Review the CV Y/N? ","No","Enter Yes or No to Review the Coverage Limitations <or> ^ to Quit"))
;
ASKYR() ; Prompt to Enter a New or Existing AB year
Q $$READ^IBCNBAA("DA^::EX","Enter Existing Date or Add New Coverage Date: ","","Enter a New/Existing Coverage Limitation Date <or> ^ to Quit")
;
ASKADD(IBTXT,IBDATE) ; Prompt to ask user to add new coverage CATEGORY
Q $E($$READ^IBCNBAA("YA^::E","There is no "_IBTXT_" Coverage Category for year "_$P(IBDATE,U,2)_". Do you want to add it now Y/N? ","No","Enter Yes or No to add the record now <or> ^ to Quit"))
;
EDTYR(IBDATE,IBTXT) ; Prompt to Edit an existing Coverage Date
Q +$$READ^IBCNBAA("YA^::E","Are you sure you want to Edit "_IBTXT_" Coverage Date information: "_$P(IBDATE,U,2)_" Y/N?: ","","Enter Yes or No to Edit the Coverage Date")
;
CREYR(IBDATE) ; Prompt to Create a new Coverage Date
Q +$$READ^IBCNBAA("YA^::E","Are you sure you want to Create a new Coverage Date: "_$P(IBDATE,U,2)_" Y/N? ","","Enter Yes or No to Create a New Coverage Year Date")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBCD2 16375 printed Dec 13, 2024@02:13:49 Page 2
IBCNBCD2 ;ALB/AWC - MCCF FY14 Display Group Plan Coverage Limitations from Insurance Buffer entry ;25 Feb 2015
+1 ;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Input Parameters:
+5 ; See routine IBCNBCD1
+6 ;
COVLIM(IBBUFDA,IBGRPDA,IBCSAV,IBQ,IBERR) ; Coverage Limitations entry point. - Called from routine ACCOV^IBCNBAA
+1 NEW IBGSAV,IBSYS,IBDATE,IBDTL,IBFOUND,IBDATA,IBEDIT,IBOUT,IBPLAN,IBYES,IBTXT,IBN,DTOUT
+2 SET IBN=0
SET IBTXT=""
+3 ;
+4 ; -- **** CAUTION DO NOT KILL ****
+5 ; -- **** VistA System Coverage Limitation Global ****
NEW IBSYS
SET IBSYS=$NAME(^IBA(355.32))
+6 ; -- **** CAUTION DO NOT KILL ****
+7 ;
+8 ;
+9 FOR
SET IBQ=$$ASKREV()
if IBQ'=1!($DATA(DTOUT))
QUIT
Begin DoDot:1
+10 ;
+11 ; -- display a list of coverage limitations years for the group policy
+12 DO CVDTS(IBGRPDA,.IBDTL)
+13 ;
+14 ; -- prompt user to select coverage limitation year
+15 SET IBDATE=$$ASKYR()
if $EXTRACT(IBDATE)=U!($DATA(DTOUT))
QUIT
+16 ;
+17 ; -- get data for selected coverage limitation year
+18 SET IBFOUND=$$CVDATA(IBDATE,.IBDTL,.IBGSAV,.IBSYS,.IBDATA,.IBERR)
if $DATA(IBERR)
QUIT
+19 ;
+20 ; -- user entered a new date not found in the display list
+21 IF 'IBFOUND
Begin DoDot:2
+22 ;
+23 ; -- ask user to create new benifit year
+24 SET IBYES=$$CREYR(.IBDATE)
if 'IBYES
QUIT
+25 ;
+26 ; -- create a new record entry
+27 DO CVDLC(IBGRPDA,IBDATE,.IBDTL,.IBERR)
if $DATA(IBERR)
QUIT
+28 ;
+29 ; -- get data for newly created record
+30 SET IBFOUND=$$CVDATA(IBDATE,.IBDTL,.IBGSAV,.IBSYS,.IBDATA,.IBERR)
if $DATA(IBERR)
QUIT
+31 SET IBN=1
+32 ;
End DoDot:2
if 'IBYES!('IBFOUND)!($DATA(IBERR))
QUIT
+33 ;
+34 ; -- get coverage plans and display coverage limitations for selected year
+35 DO CVPLAN(.IBPLAN)
SET IBOUT=$$CVDISP^IBCNBCD3(.IBDATA,.IBPLAN)
if IBOUT
QUIT
+36 ;
+37 ; -- edit coverage limitations
+38 SET IBTXT=$SELECT(IBN:"the NEW",1:"existing")
+39 SET IBEDIT=$$EDTYR(IBDATE,IBTXT)
IF IBEDIT
DO CVEDIT(IBGRPDA,.IBGSAV,.IBSYS,IBDATE,.IBCSAV,.IBDATA,.IBERR)
+40 SET IBN=0
+41 ;
End DoDot:1
if $DATA(IBERR)
QUIT
+42 DO CVOUT(.IBDATA)
+43 QUIT
+44 ;
CVDTS(IBGRPDA,IBDTL) ; Display a list of Coverage Limitations Years to select
+1 NEW IBI,IBIEN,IBDT,IBXDT,IBIDT,IBRET
+2 ;
+3 SET IBDTL=$NAME(^TMP("IBCNBCD2 CVDTS DATES",$JOB))
+4 KILL @IBDTL
+5 ;
+6 FOR IBI=0:0
SET IBI=$ORDER(^IBA(355.32,"APCD",IBGRPDA,IBI))
if IBI'>0
QUIT
Begin DoDot:1
+7 SET IBDT=""
FOR
SET IBDT=$ORDER(^IBA(355.32,"APCD",IBGRPDA,IBI,IBDT))
if IBDT=""
QUIT
Begin DoDot:2
+8 SET IBIEN=$ORDER(^IBA(355.32,"APCD",IBGRPDA,IBI,IBDT,0))
+9 SET IBIDT=-(IBDT)
DO DT^DILF("E",IBIDT,.IBRET)
SET IBXDT=$GET(IBRET(0))
+10 ;
+11 ; -- put dates in assending order - example: S @IBDTL@(nncyyddmm,IEN)=mmm dd, yyyy
+12 IF IBXDT["JAN"
SET @IBDTL@(11_IBIDT,IBIEN)=IBXDT
QUIT
+13 IF IBXDT["FEB"
SET @IBDTL@(12_IBIDT,IBIEN)=IBXDT
QUIT
+14 IF IBXDT["MAR"
SET @IBDTL@(13_IBIDT,IBIEN)=IBXDT
QUIT
+15 IF IBXDT["APR"
SET @IBDTL@(14_IBIDT,IBIEN)=IBXDT
QUIT
+16 IF IBXDT["MAY"
SET @IBDTL@(15_IBIDT,IBIEN)=IBXDT
QUIT
+17 IF IBXDT["JUN"
SET @IBDTL@(16_IBIDT,IBIEN)=IBXDT
QUIT
+18 IF IBXDT["JUL"
SET @IBDTL@(17_IBIDT,IBIEN)=IBXDT
QUIT
+19 IF IBXDT["AUG"
SET @IBDTL@(18_IBIDT,IBIEN)=IBXDT
QUIT
+20 IF IBXDT["SEP"
SET @IBDTL@(19_IBIDT,IBIEN)=IBXDT
QUIT
+21 IF IBXDT["OCT"
SET @IBDTL@(20_IBIDT,IBIEN)=IBXDT
QUIT
+22 IF IBXDT["NOV"
SET @IBDTL@(21_IBIDT,IBIEN)=IBXDT
QUIT
+23 IF IBXDT["DEC"
SET @IBDTL@(22_IBIDT,IBIEN)=IBXDT
End DoDot:2
End DoDot:1
+24 ;
+25 WRITE !!,"Coverage Date:",!
+26 FOR IBDT=0:0
SET IBDT=$ORDER(@IBDTL@(IBDT))
if IBDT'>0
QUIT
SET IBIEN=$ORDER(@IBDTL@(IBDT,0))
WRITE ?2,@IBDTL@(IBDT,IBIEN),!
+27 QUIT
CVDATA(IBDATE,IBDTL,IBGSAV,IBSYS,IBDATA,IBERR) ; Get data for the selected year
+1 NEW IBI,IBJ,IBHOLD,IBFLDS,IBCDA,IBIEN,IBPLN,IBDAT,IBLOCK
+2 SET IBDATA=$NAME(^TMP("IBCNBCD2 CVDATA DATA",$JOB))
+3 SET IBGSAV=$NAME(^TMP("IBCNBCD2 IB CV GSAV",$JOB))
+4 KILL @IBDATA,@IBGSAV
+5 ; ;
+6 SET IBDAT=0
SET IBFLDS=".02;.03;.04"
+7 ;
+8 FOR IBI=0:0
SET IBI=$ORDER(@IBDTL@(IBI))
if IBI'>0
QUIT
IF $EXTRACT(IBI,3,$LENGTH(IBI))=+IBDATE
Begin DoDot:1
+9 FOR IBIEN=0:0
SET IBIEN=$ORDER(@IBDTL@(IBI,IBIEN))
if IBIEN'>0
QUIT
Begin DoDot:2
+10 ;
+11 SET IBHOLD=$NAME(^TMP("IBCNBCD2 CVDATA HOLD",$JOB))
+12 KILL @IBHOLD
+13 DO GETS^DIQ(355.32,IBIEN_",",.IBFLDS,"IE",.IBHOLD,"IBERR")
IF $DATA(IBERR)
WRITE !,"***Error...CVDATA^IBCNBCD2 Cannot retrieve Coverage Limitations data fields."
DO PAUSE^VALM1
QUIT
+14 SET IBPLN=@IBHOLD@(355.32,IBIEN_",",.02,"E")
+15 MERGE @IBDATA@(IBPLN)=@IBHOLD@(355.32,IBIEN_",")
+16 ; -- top level so set it to the IEN
SET @IBDATA@(IBPLN)=IBIEN
+17 ; -- lock the record
SET IBLOCK=$$CVLOCK(IBIEN,.IBSYS)
IF 'IBLOCK
SET IBERR=1
QUIT
+18 ;
+19 ; -- save off the system global data
+20 SET @IBGSAV@(IBIEN,0)=$GET(^IBA(355.32,IBIEN,0))
+21 SET @IBGSAV@(IBIEN,1)=$GET(^IBA(355.32,IBIEN,1))
+22 SET @IBGSAV@(IBIEN,2,0)=$GET(^IBA(355.32,IBIEN,2,0))
+23 ;
+24 FOR IBJ=0:0
SET IBJ=$ORDER(^IBA(355.32,IBIEN,2,IBJ))
if IBJ'>0
QUIT
Begin DoDot:3
+25 SET @IBDATA@(IBPLN,"COMM",IBJ)=^IBA(355.32,IBIEN,2,IBJ,0)
+26 ; -- save off the system global comments data
SET @IBGSAV@(IBIEN,2,IBJ,0)=$GET(^IBA(355.32,IBIEN,2,IBJ,0))
End DoDot:3
End DoDot:2
if $DATA(IBERR)
QUIT
End DoDot:1
if $DATA(IBERR)
QUIT
+27 ;
+28 IF $DATA(@IBDATA)
SET IBDAT=1
+29 QUIT IBDAT
+30 ;
CVPLAN(IBPLAN) ; Display/Edit Coverage Limitations for selected date
+1 NEW IBI,IBJ
+2 SET IBPLAN=$NAME(^TMP("IBCNBCD2 CVDSEL PLAN COV",$JOB))
+3 KILL @IBPLAN
+4 ;
+5 SET IBI=""
FOR
SET IBI=$ORDER(^IBE(355.31,"B",IBI))
if IBI']""
QUIT
SET IBJ=$ORDER(^IBE(355.31,"B",IBI,0))
SET @IBPLAN@(IBI,IBJ)=""
+6 QUIT
+7 ;
CVLOCK(IBIEN,IBSYS) ; Lock the Coverage Limitations records
+1 NEW IBOUT
+2 SET IBOUT=1
+3 LOCK +@IBSYS@(IBIEN):5
IF '$TEST
SET IBOUT=0
DO CVLKD
+4 QUIT IBOUT
+5 ;
CVEDIT(IBGRPDA,IBGSAV,IBSYS,IBDATE,IBCSAV,IBDATA,IBERR) ; Edit Coverage Limitations via Input Template 355.32
+1 NEW IBI,IBIEN,IBDR,IBDIF,IBSAV,IBADD,IBOUT,IBPLC
+2 NEW IBIP,IBOP,IBPH,IBDN,IBMH,IBLT
+3 NEW IBCI,IBCO,IBCP,IBCD,IBCM,IBCL
+4 ;
+5 ; -- check if data for the coverage categories
+6 ; -- DA's of the IBDATA global holding the record location
SET (IBOP,IBIP,IBPH,IBLT,IBDN,IBMH)=""
+7 ; -- pointers to the PLAN LIMITATION CATEGORY FILE (#355.31)
SET (IBCI,IBCO,IBCP,IBCD,IBCM,IBCL)=""
+8 ;
+9 ; -- get plan limitation categories ien'S
+10 SET IBPLC=$NAME(^TMP("IBCNBCD2 IB PLAN LIM CATEGORIES",$JOB))
+11 KILL @IBPLC
+12 DO LIST^DIC(355.31,,"@;.01E",,,,,"B",,,.IBPLC,"IBERR")
IF $DATA(IBERR)
WRITE !,"*** Error...CVEDIT^IBCNBCD2 Cannot access Plan Limitations Category File!"
DO PAUSE^VALM1
QUIT
+13 FOR IBI=0:0
SET IBI=$ORDER(@IBPLC@("ID",IBI))
if IBI'>0
QUIT
Begin DoDot:1
+14 IF @IBPLC@("ID",IBI,.01)="DENTAL"
SET IBCD=@IBPLC@(2,IBI)
QUIT
+15 IF @IBPLC@("ID",IBI,.01)="OUTPATIENT"
SET IBCO=@IBPLC@(2,IBI)
QUIT
+16 IF @IBPLC@("ID",IBI,.01)="PHARMACY"
SET IBCP=@IBPLC@(2,IBI)
QUIT
+17 IF @IBPLC@("ID",IBI,.01)="INPATIENT"
SET IBCI=@IBPLC@(2,IBI)
QUIT
+18 IF @IBPLC@("ID",IBI,.01)="MENTAL HEALTH"
SET IBCM=@IBPLC@(2,IBI)
QUIT
+19 IF @IBPLC@("ID",IBI,.01)="LONG TERM CARE"
SET IBCL=@IBPLC@(2,IBI)
End DoDot:1
+20 ;
+21 ; -- check if our data list contain plan coverage limitations
+22 SET IBI=""
+23 FOR
SET IBI=$ORDER(@IBDATA@(IBI))
if IBI']""
QUIT
Begin DoDot:1
+24 IF IBI="INPATIENT"
SET IBIP=IBI
QUIT
+25 IF IBI="OUTPATIENT"
SET IBOP=IBI
QUIT
+26 IF IBI="PHARMACY"
SET IBPH=IBI
QUIT
+27 IF IBI="DENTAL"
SET IBDN=IBI
QUIT
+28 IF IBI="MENTAL HEALTH"
SET IBMH=IBI
QUIT
+29 IF IBI="LONG TERM CARE"
SET IBLT=IBI
End DoDot:1
+30 ;
+31 ;
+32 WRITE !!,"---------------------- EDIT COVERAGE LIMITATIONS INFORMATION -----------------------",!
+33 ;
+34 ; -- inpatient
+35 IF IBIP]""
Begin DoDot:1
+36 SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBIP))
SET IBDR="[IBCNBC CV IP EDIT]"
+37 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+38 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+39 IF IBDIF
SET IBSAV=$$CVASK()
+40 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBIP,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+41 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+42 IF IBIP']""
SET IBADD=$$ASKADD("INPATIENT",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCI,IBDATE,.IBERR)
QUIT
+43 ;
+44 ; -- outpatient
+45 IF IBOP]""
Begin DoDot:1
+46 WRITE !
SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBOP))
SET IBDR="[IBCNBC CV OP EDIT]"
+47 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+48 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+49 IF IBDIF
SET IBSAV=$$CVASK()
+50 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBOP,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+51 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+52 IF IBOP']""
SET IBADD=$$ASKADD("OUTPATIENT",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCO,IBDATE,.IBERR)
QUIT
+53 ;
+54 ; -- pharmacy
+55 IF IBPH]""
Begin DoDot:1
+56 WRITE !
SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBPH))
SET IBDR="[IBCNBC CV PH EDIT]"
+57 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+58 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+59 IF IBDIF
SET IBSAV=$$CVASK()
+60 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBPH,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+61 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+62 IF IBPH']""
SET IBADD=$$ASKADD("PHARMACY",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCP,IBDATE,.IBERR)
QUIT
+63 ;
+64 ; -- dental
+65 IF IBDN]""
Begin DoDot:1
+66 WRITE !
SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBDN))
SET IBDR="[IBCNBC CV DN EDIT]"
+67 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+68 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+69 IF IBDIF
SET IBSAV=$$CVASK()
+70 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBDN,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+71 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+72 IF IBDN']""
SET IBADD=$$ASKADD("DENTAL",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCD,IBDATE,.IBERR)
QUIT
+73 ;
+74 ; -- mental health
+75 IF IBMH]""
Begin DoDot:1
+76 WRITE !
SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBMH))
SET IBDR="[IBCNBC CV MH EDIT]"
+77 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+78 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+79 IF IBDIF
SET IBSAV=$$CVASK()
+80 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBMH,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+81 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+82 IF IBMH']""
SET IBADD=$$ASKADD("MENTAL HEALTH",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCM,IBDATE,.IBERR)
QUIT
+83 ;
+84 ; -- long term
+85 IF IBLT]""
Begin DoDot:1
+86 WRITE !
SET IBOUT=0
SET IBIEN=$GET(@IBDATA@(IBLT))
SET IBDR="[IBCNBC CV LT EDIT]"
+87 DO EDTREC(IBIEN,IBDR)
IF $GET(Y(0))="AUDIT"
SET IBOUT=1
QUIT
+88 SET IBDIF=$$CVDIF(.IBSYS,.IBGSAV,IBIEN)
SET IBSAV=1
+89 IF IBDIF
SET IBSAV=$$CVASK()
+90 IF (IBDIF&('IBSAV))!($DATA(DTOUT))
DO CVUNDO(IBIEN,IBLT,.IBSYS,.IBGSAV,.IBDATA,.IBERR)
QUIT
+91 IF (IBDIF&(IBSAV))&('$DATA(DTOUT))
SET IBCSAV=1
End DoDot:1
if IBOUT!($DATA(IBERR))!($DATA(DTOUT))
QUIT
+92 IF IBLT']""
SET IBADD=$$ASKADD("LONG TERM",IBDATE)
if IBADD=U
QUIT
IF IBADD
if '$$ADDCV(IBGRPDA,IBCL,IBDATE,.IBERR)
QUIT
+93 QUIT
+94 ;
CVUNDO(IBIEN,IBPL,IBSYS,IBGSAV,IBDATA,IBERR) ; - undo any coverage limitations edits
+1 NEW X,Y,DA,DIC,DIK,IBI,IBJ,IBFLD,IBIENH,IBFDA
+2 ;
+3 SET IBFDA=$NAME(^TMP("IBCNBCD2 CV EDIT FDA",$JOB))
+4 KILL @IBFDA
+5 ;
+6 ; -- updo edits except for comments
+7 FOR IBFLD=.01:0
SET IBFLD=$ORDER(@IBDATA@(IBPL,IBFLD))
if IBFLD'>0
QUIT
SET @IBFDA@(355.32,IBIEN_",",IBFLD)=$GET(@IBDATA@(IBPL,IBFLD,"E"))
+8 DO FILE^DIE("E",.IBFDA,"IBERR")
IF $DATA(IBERR)
SET IBERR=1
WRITE !,!,"*** Error...CVUNDO^IBCNBCD2 Cannot update Fields in the Coverage Limitations file! ",!
KILL @IBFDA
DO PAUSE^VALM1
+9 ;
+10 ; -- put back any deleted comments
+11 SET IBJ=0
+12 FOR IBI=0:0
SET IBI=$ORDER(@IBDATA@(IBPL,"COMM",IBI))
if IBI'>0
QUIT
Begin DoDot:1
+13 ;
+14 ; -- if comment subscript deleted - add the comment
+15 IF $GET(@IBSYS@(IBIEN,2,IBI,0))']""
Begin DoDot:2
+16 SET DIC="^IBA(355.32,"_IBIEN_",2,"
SET DIC(0)="L"
SET DA(1)=IBIEN
SET DA=IBI
SET X=@IBDATA@(IBPL,"COMM",IBI)
+17 DO FILE^DICN
IF '+Y
SET IBERR=1
WRITE !,!,"*** Error...Cannot Add 'deleted' Comments in the Coverage Limitations file! ",!
DO PAUSE^VALM1
+18 ;
End DoDot:2
+19 SET IBJ=IBI
End DoDot:1
if $DATA(IBERR)
QUIT
+20 ;
+21 ; -- delete any added comments
+22 IF +IBJ
FOR IBI=IBJ:0
SET IBI=$ORDER(@IBSYS@(IBIEN,2,IBI))
if IBI'>0
QUIT
Begin DoDot:1
+23 SET DA(1)=IBIEN
SET DIK="^IBA(355.32,"_DA(1)_",2,"
SET DA=IBI
+24 DO ^DIK
KILL DA,DIK
End DoDot:1
+25 ;
+26 ; -- put modified comments into fda array
+27 SET IBI=0
SET IBIENH=$GET(@IBDATA@(IBPL))_","
+28 FOR IBFLD=0:0
SET IBFLD=$ORDER(@IBDATA@(IBPL,"COMM",IBFLD))
if IBFLD'>0
QUIT
Begin DoDot:1
+29 SET IBIEN=IBFLD_","_IBIENH
+30 SET @IBFDA@(355.321,IBIEN,0)=$GET(@IBDATA@(IBPL,"COMM",IBFLD))
End DoDot:1
+31 ;
+32 ; -- undo any modified comments
+33 IF $DATA(@IBFDA)>9
Begin DoDot:1
+34 DO FILE^DIE("E",.IBFDA,"IBERR")
+35 IF $DATA(IBERR)
WRITE !,!,"*** Error...CVUNDO^IBCNBCD2 Cannot Put Original Comments in the Coverage Limitations file! ",!
DO PAUSE^VALM1
End DoDot:1
+36 QUIT
+37 ;
CVDLC(IBGRPDA,IBDATE,IBDTL,IBERR) ; Create records for the new coverage limitation year
+1 NEW IBI,IBPCC,IBIP,IBOP,IBPH,IBDN,IBMH,IBLT,IBIEN,IBDT,IBFDT
+2 ;
+3 SET IBDTL=$NAME(^TMP("IBCNBCD2 CVDTS DATES",$JOB))
SET IBPCC=$NAME(^TMP("IBCNBCD2 IB COVERAGE CAT",$JOB))
+4 KILL @IBDTL,@IBPCC
+5 ;
+6 ; -- get coverage categories
+7 DO LIST^DIC(355.31,,"@;.01E",,,,,"B","",,.IBPCC,"IBERR")
IF $DATA(IBERR)
WRITE !,"Error...CVDLC^IBCNBCD2 Cannot access PLAN LIMITATION CATEGORY FILE!"
DO PAUSE^VALM1
QUIT
+8 SET (IBIP,IBOP,IBPH,IBDN,IBMH,IBLT)=0
+9 FOR IBI=0:0
SET IBI=$ORDER(@IBPCC@("ID",IBI))
if IBI'>0
QUIT
Begin DoDot:1
+10 IF @IBPCC@("ID",IBI,.01)="INPATIENT"
SET IBIP=@IBPCC@(2,IBI)
QUIT
+11 IF @IBPCC@("ID",IBI,.01)="OUTPATIENT"
SET IBOP=@IBPCC@(2,IBI)
QUIT
+12 IF @IBPCC@("ID",IBI,.01)="PHARMACY"
SET IBPH=@IBPCC@(2,IBI)
QUIT
+13 IF @IBPCC@("ID",IBI,.01)="DENTAL"
SET IBDN=@IBPCC@(2,IBI)
QUIT
+14 IF @IBPCC@("ID",IBI,.01)="MENTAL HEALTH"
SET IBMH=@IBPCC@(2,IBI)
QUIT
+15 IF @IBPCC@("ID",IBI,.01)="LONG TERM CARE"
SET IBLT=@IBPCC@(2,IBI)
End DoDot:1
+16 ;
+17 ; -- add new records to the database
+18 IF IBIP&(IBOP)&(IBPH)&(IBDN)&(IBMH)&(IBLT)
Begin DoDot:1
+19 ;
+20 ; -- format the date
+21 SET IBDT=+IBDATE
DO DT^DILF("E",IBDT,.IBRET)
SET IBFDT=$GET(IBRET(0))
+22 ;
+23 ; -- load the coverage limitation date array with formatted date
+24 SET IBIEN=$$ADDCV(IBGRPDA,IBIP,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
+25 SET IBIEN=$$ADDCV(IBGRPDA,IBOP,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
+26 SET IBIEN=$$ADDCV(IBGRPDA,IBPH,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
+27 SET IBIEN=$$ADDCV(IBGRPDA,IBDN,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
+28 SET IBIEN=$$ADDCV(IBGRPDA,IBMH,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
+29 SET IBIEN=$$ADDCV(IBGRPDA,IBLT,IBDATE,.IBERR)
if $DATA(IBERR)
QUIT
SET @IBDTL@(99_IBDT,IBIEN)=IBFDT
End DoDot:1
if $DATA(IBERR)
QUIT
+30 QUIT
+31 ;
ADDCV(IBGRPDA,IBCAT,IBDATE,IBERR) ; Add new coverage limitation record
+1 NEW X,Y,DA,DIC,IBIEN,IBA,IBB,IBC
+2 SET IBIEN=0
SET IBC="COVERED"
+3 ;
+4 ; -- retrieve the plan limitation category
+5 SET IBA=$$GET1^DIQ(355.31,IBCAT_",",.01,"E")
IF IBA']""
SET IBERR=1
WRITE !,"Error #1...ADDCV-IBCNBCD2 Cannot retrieve PLAN LIMITATION CATEGORY!"
DO PAUSE^VALM1
QUIT IBIEN
+6 SET IBB=$PIECE(IBDATE,U,2)
+7 ;
+8 ; -- update plan coverage limitation file
+9 SET DIC="^IBA(355.32,"
SET DIC(0)="L"
SET X=IBGRPDA
SET DIC("DR")=".02///^S X=IBA;.03///^S X=IBB;.04///^S X=IBC"
+10 DO FILE^DICN
SET IBIEN=+Y
IF IBIEN<0!(IBIEN=0)
SET IBERR=1
WRITE !,"Error #2...ADDCV-IBCNBCD2 Cannot add New Record to the PLAN COVERAGE LIMITATIONS FILE!"
DO PAUSE^VALM1
+11 QUIT IBIEN
+12 ;
CVDIF(IBSYS,IBGSAV,IBIEN) ; -- check for any edits made to coverage limitations
+1 NEW IBI,IBDIF
+2 SET IBDIF=0
+3 IF $GET(@IBSYS@(IBIEN,0))'=$GET(@IBGSAV@(IBIEN,0))
SET IBDIF=1
QUIT IBDIF
+4 IF $GET(@IBSYS@(IBIEN,1))'=$GET(@IBGSAV@(IBIEN,1))
SET IBDIF=1
QUIT IBDIF
+5 IF $GET(@IBSYS@(IBIEN,2,0))'=$GET(@IBGSAV@(IBIEN,2,0))
SET IBDIF=1
QUIT IBDIF
+6 IF $DATA(@IBSYS@(IBIEN,2,0))
Begin DoDot:1
+7 FOR IBI=0:0
SET IBI=$ORDER(@IBSYS@(IBIEN,2,IBI))
if IBI'>0!(IBDIF)
QUIT
IF $GET(@IBSYS@(IBIEN,2,IBI,0))'=$GET(@IBGSAV@(IBIEN,2,IBI,0))
SET IBDIF=1
QUIT
End DoDot:1
+8 QUIT IBDIF
+9 ;
EDTREC(IBIEN,IBDR) ; Edit Coverage Limitaitons
+1 NEW DA,DR,DIE
+2 SET DA=IBIEN
SET DR=IBDR
+3 SET DIE="^IBA(355.32,"
SET DIE("NO^")="BACKOUTOK"
+4 DO ^DIE
+5 QUIT
+6 ;
CVOUT(IBDATA) ; -- unlock coverage limitations records
+1 NEW IBI,IBIEN
+2 IF $DATA(IBDATA)>9
Begin DoDot:1
+3 SET IBI=""
+4 FOR
SET IBI=$ORDER(@IBDATA@(IBI))
if IBI']""
QUIT
SET IBIEN=$GET(@IBDATA@(IBI))
LOCK -@IBSYS@(IBIEN)
End DoDot:1
+5 QUIT
+6 ;
CVLKD ; -- write locked message
+1 WRITE !!,"Sorry, another user currently editing this entry."
+2 WRITE !,"Try again in a few minutes."
+3 DO PAUSE^VALM1
+4 QUIT
+5 ;
CVASK() ; Prompt to ask user to Save Changes
+1 QUIT $EXTRACT($$READ^IBCNBAA("YA^::E","Save Changes to Coverage Limitations File Y/N? ","No","Enter Yes or No to Save the Changes to the CV File <or> ^ to Quit"))
+2 ;
ASKREV() ; Prompt to review Coverage Limitations
+1 QUIT $EXTRACT($$READ^IBCNBAA("YA^::E","Do you want to Review the CV Y/N? ","No","Enter Yes or No to Review the Coverage Limitations <or> ^ to Quit"))
+2 ;
ASKYR() ; Prompt to Enter a New or Existing AB year
+1 QUIT $$READ^IBCNBAA("DA^::EX","Enter Existing Date or Add New Coverage Date: ","","Enter a New/Existing Coverage Limitation Date <or> ^ to Quit")
+2 ;
ASKADD(IBTXT,IBDATE) ; Prompt to ask user to add new coverage CATEGORY
+1 QUIT $EXTRACT($$READ^IBCNBAA("YA^::E","There is no "_IBTXT_" Coverage Category for year "_$PIECE(IBDATE,U,2)_". Do you want to add it now Y/N? ","No","Enter Yes or No to add the record now <or> ^ to Quit"))
+2 ;
EDTYR(IBDATE,IBTXT) ; Prompt to Edit an existing Coverage Date
+1 QUIT +$$READ^IBCNBAA("YA^::E","Are you sure you want to Edit "_IBTXT_" Coverage Date information: "_$PIECE(IBDATE,U,2)_" Y/N?: ","","Enter Yes or No to Edit the Coverage Date")
+2 ;
CREYR(IBDATE) ; Prompt to Create a new Coverage Date
+1 QUIT +$$READ^IBCNBAA("YA^::E","Are you sure you want to Create a new Coverage Date: "_$PIECE(IBDATE,U,2)_" Y/N? ","","Enter Yes or No to Create a New Coverage Year Date")
