- 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 Feb 18, 2025@23:40:13 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")