IBCNSJ54 ;AITC/CKB - INSURANCE PLAN MAINTENANCE ACTION COVERAGE LIMITS ; 02-OCT-2024
;;2.0;INTEGRATED BILLING;**804**;21-MAR-94;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
;
Q
EN ; -- main entry point for ADD/EDIT COVERAGE
S VALMBCK="R",VALMBG=1,VALMCNT=0
S IBSORT="1^Coverage Category"
D EN^VALM("IBCNS ADD/EDIT COVERAGE")
Q
;
HDR ; -- header code
N COVFN,GIENS,GIND,GINACT,GNAME,GNUM,IBCBY,IBCDT,LASTUPD,LSTBY,LSTDT
D GRPHDR
S VALMHDR(1)="Group Name: "_GNAME,$E(VALMHDR(1),40,79)="Group Number: "_GNUM
;LASTUPD = COVERAGE Last Updated <date> by <who>
S VALMHDR(2)=LASTUPD
S VALMHDR(3)="Sorted by: "_$S(IBSORT'="":$P(IBSORT,U,2),1:"Coverage Category")
S VALMHDR(4)=" "
Q
;
INIT ; -- init variables and list array
; Initialize variables and list array
; Input: None
; Output: ^TMP("IBCNSJ54",$J) - Body lines to display
K ^TMP("IBCNSJ54",$J),^TMP("IBCNSJ54X"),^TMP($J,"IBCNSJ54")
S:$G(IBSORT)="" IBSORT="1^Coverage Category"
D BLD
Q
;
GRPHDR ; Get GROUP PLAN HEADER info
;Get Group Name and Group Number
; IBCPOL - IEN in the GROUP INSURANCE PLAN file #355.3
N IB3553,IBARR,IBCPOL1
K IBARR,IB3553
S IBCPOL1=IBCPOL_","
D GETS^DIQ(355.3,IBCPOL1,".1;.11;2.01;2.02","EI","IBARR") M IB3553=IBARR(355.3,IBCPOL1)
S GIND=$G(IB3553(.1,"I")),GINACT=$G(IB3553(.11,"I"))
S GNAME=$G(IB3553(2.01,"E")),GNUM=$G(IB3553(2.02,"E"))
S:GNAME="" GNAME="<NO GROUP NAME>" S:GNUM="" GNUM="<NO GROUP NUMBER>"
; Add '+'=individual and/or '*'=inactive
I GIND'="" S GNAME="+"_GNAME
I GINACT S GNUM="*"_GNUM
;Get COVERAGE Last Updated <date> by <who>
S LASTUPD="COVERAGE Last Updated by "
I $D(^IBA(355.32,"LAST",IBCPOL)) D
. S IBCDT=$O(^IBA(355.32,"LAST",IBCPOL,"")),IBCBY=$O(^IBA(355.32,"LAST",IBCPOL,IBCDT,""))
. S COVFN=$O(^IBA(355.32,"LAST",IBCPOL,IBCDT,IBCBY,"")),GIENS=COVFN_","
. S LSTDT=$$GET1^DIQ(355.32,GIENS,1.03,"I"),LSTBY=$$GET1^DIQ(355.32,GIENS,1.04,"E")
. S LASTUPD="COVERAGE Last Updated "_$$FO^IBCNEUT1($$FMTE^XLFDT(LSTDT,"5Z"),10)_" by "_LSTBY
Q
;
BLD ; Build listman display
; IBCPOL - IEN in the GROUP INSURANCE PLAN file #355.3
; IBSORT - order of the Coverages dislayed on the screen
; VALMCNT - Total number of lines displayed in the body
;
; ^TMP("IBCNSJ54",$J) - contains the lines to be displayed
; ^TMP("IBCNSJ54X",$J) - IEN file #55.32 ^ Coverage Category ^ Eff Date ^ Covered? ^ Limit Comment
; ^TMP($J,"IBCNSJ54") - contains the sorted output
;
; Build display of a Group Plan Coverage data
N CATARR,CDATA,CTR,GINACT,GIND,GNAME,GNUM,GTYP,I,IBCAT,IBCCAT,IBCOV,IBCSTA,IBDT,IBCVREC
N IBEDT,IBEFDT,IBLIMCOM,IBRECDT,IBREC,IBRECN,ICTR,LINE,RTN
K ^TMP("IBCNSJ54",$J),^TMP("IBCNSJ54X")
K ^TMP($J,"IBCNSJ54")
S (ICTR,VALMCNT)=0
S RTN="IBCNSJ54"
; Compile Plan Coverage Limitation info
; File# 355.31 PLAN LIMITATION CATEGORY contains ALL coverage categories
F I=1:1:$O(^IBE(355.31,"B"),-1) S IBCAT=I D
. K IBEDT,IBCSTA,IBCVREC,IBRECN
. ; If the Category doesn't exist for the Plan the Coverage Status is BY DEFAULT
. I '$D(^IBA(355.32,"APCD",IBCPOL,I)) D Q
. . S IBCAT=I,IBRECN="",IBEDT=0
. . S IBCSTA="BY DEFAULT" ; Coverage Status
. . S IBCOV=$$GET1^DIQ(355.31,I,.01,"E") ; Coverage Category
. . S IBCVREC=IBCOV_U_U_IBCSTA
. . S ICTR=ICTR+1
. . ; SORT BY: 1-Coverage / 2-Effective Date / 3-Covered?
. . I $P(IBSORT,U)=1 S ^TMP($J,RTN,IBCAT,-IBEDT,IBCSTA)=IBCVREC_"|"_IBRECN
. . I $P(IBSORT,U)=2 S ^TMP($J,RTN,-IBEDT,IBCAT,IBCSTA)=IBCVREC_"|"_IBRECN
. . I $P(IBSORT,U)=3 S ^TMP($J,RTN,IBCSTA,IBCAT,-IBEDT)=IBCVREC_"|"_IBRECN
. S IBRECDT=""
. F S IBRECDT=$O(^IBA(355.32,"APCD",IBCPOL,IBCAT,IBRECDT)) Q:IBRECDT="" D
. . S IBRECN=""
. . F S IBRECN=$O(^IBA(355.32,"APCD",IBCPOL,IBCAT,IBRECDT,IBRECN)) Q:IBRECN="" D
. . . S IBCOV=$$GET1^DIQ(355.32,IBRECN,.02) ; Coverage Category
. . . S IBEDT=$$GET1^DIQ(355.32,IBRECN,.03,"I")
. . . S IBEFDT=$$DAT3^IBOUTL(IBEDT) ; Effective Date
. . . S IBCSTA=$$GET1^DIQ(355.32,IBRECN,.04,"I") ; Coverage Status
. . . S IBCSTA=$S(IBCSTA="":"BY DEFAULT",IBCSTA=0:"NO",IBCSTA=1:"YES",1:"CONDITIONAL")
. . . S IBLIMCOM="" D LIMCOM ; Limit Comments?
. . . S IBCVREC=IBCOV_U_IBEFDT_U_IBCSTA_U_IBLIMCOM
. . . S ICTR=ICTR+1
. . . ; SORT BY: 1-Coverage / 2-Effective Date / 3-Covered?
. . . I $P(IBSORT,U)=1 S ^TMP($J,RTN,IBCAT,-IBEDT,IBCSTA)=IBCVREC_"|"_IBRECN
. . . I $P(IBSORT,U)=2 S ^TMP($J,RTN,-IBEDT,IBCAT,IBCSTA)=IBCVREC_"|"_IBRECN
. . . I $P(IBSORT,U)=3 S ^TMP($J,RTN,IBCSTA,IBCAT,-IBEDT)=IBCVREC_"|"_IBRECN
;
; Loop through the sorted data and build the lines to be displayed
N LINE,SCT,SORT1,SORT2,SORT3,SREC,SRECN
S SCT=0
S SORT1="" F S SORT1=$O(^TMP($J,RTN,SORT1)) Q:SORT1="" D
. S SORT2="" F S SORT2=$O(^TMP($J,RTN,SORT1,SORT2)) Q:SORT2="" D
. . S SORT3="" F S SORT3=$O(^TMP($J,RTN,SORT1,SORT2,SORT3)) Q:SORT3="" S SCT=SCT+1 D
. . . S SREC=$P(^TMP($J,RTN,SORT1,SORT2,SORT3),"|")
. . . S SRECN=$P(^TMP($J,RTN,SORT1,SORT2,SORT3),"|",2)
. . . S LINE=$$BLDLN(SCT,SREC)
. . . S VALMCNT=VALMCNT+1
. . . ; SRECN = IEN of the entry in file #355.32 - needed for Edit & Delete
. . . S ^TMP("IBCNSJ54X",$J,VALMCNT)=SREC_"|"_SRECN
. . . D SET^VALM10(VALMCNT,LINE,LINE)
;
S VALMBCK="R",VALMBG=1
Q
;
LIMCOM ;Limitation Comments from the multiple - include ALL comments
K IBLIMCOM S IBLIMCOM=""
N Z
S Z=0 F S Z=$O(^IBA(355.32,IBRECN,2,Z)) Q:'Z!(Z="") I $G(^IBA(355.32,IBRECN,2,Z,0))'="" D
. ; Append all the comments together separated by a <space>
. S IBLIMCOM=IBLIMCOM_^IBA(355.32,IBRECN,2,Z,0)_" "
Q
;
HELP ; -- help code
I $G(VALMANS)="??" S X="?" D DISP^XQORM1 W !! Q
D FULL^VALM1
N DIR,X,Y
W !!," Enter AD to Add New Coverage."
W !," Enter ED to Edit Coverage."
W !," Enter DE to Delete Coverage."
W !," Enter ST to Sort List.",!
S DIR(0)="E",DIR("A")="Press <Enter> to return to Add/Edit Coverage"
D ^DIR
K DIR,X,Y
S VALMBCK="R",VALMBG=1
Q
;
EXIT ; -- exit code
K IBSORT,^TMP("IBCNSJ54",$J),^TMP("IBCNSJ54X"),^TMP($J,"IBCNSJ54")
D CLEAN^VALM10,CLEAR^VALM1
S VALMBCK="R",VALMBG=1
Q
;
BLDLN(ICTR,IREC) ; Builds a line to display one insurance company
; Input: ICTR - Selection Number
; IREC - the Coverage data to be displayed
; Output: LINE - formatted for setting into the list display
N LINE
S LINE=$$SETSTR^VALM1(ICTR,"",1,4) ; Selection #
S LINE=$$SETSTR^VALM1($P(IREC,U),LINE,5,15) ; Category Coverage
S LINE=$$SETSTR^VALM1($P(IREC,U,2),LINE,23,10) ; Effective Date
S LINE=$$SETSTR^VALM1($P(IREC,U,3),LINE,40,11) ; Covered?
S LINE=$$SETSTR^VALM1($P(IREC,U,4),LINE,54,75) ; Limit Comments
Q LINE
;
ADD ; AD Add Coverage
N DONE,END,I,IBCCAT,IBCOV,IEN,NOW,STOP
D FULL^VALM1
S STOP=0
; prompt for the Effective Date
D SELED I $G(IBEFDT)="^"!($G(STOP)=1) G ADDX
; prompt for Coverage Category(s)
D SELCC I STOP=1 G ADDX
; if ALL was selected build IBCCAT array
I $G(IBCCAT)=0 F I=1:1:END S IBCCAT(I)=I
;Loop through the IBCCAT array
F I=1:1 Q:'$D(IBCCAT(I)) D
. N COVCAT,IBDA,IBOUT
. S COVCAT=^IBE(355.31,IBCCAT(I),0)
. W !!,$P(COVCAT,U)
. ; check for existence of this Effective Date & Coverage Category
. I $$EXISTS(IBCPOL,IBEDT) D Q
. . W !,"** "_$P(COVCAT,U)_" - data already exist for this Effective Date, nothing added **",! Q
. ; Check for effective date later than the one you entered
. ; if found ask "Are you sure you want to add this earlier date for the category? NO//" 0-NO 1-YES
. I '$$CHKEDT(IBCCAT(I)) Q
. K DIC,DO,DD
. S DIC="^IBA(355.32,",DIC(0)="L",X=IBCPOL,DIC("DR")=".02///"_$P(COVCAT,U)_";.03///"_IBEDT_";.04////1"
. D FILE^DICN
. S DA=$S(Y>0:+Y,1:0)
. S IBDA=DA
. ;
. L +^IBA(355.32,IBDA):5 I '$T D Q
. . W !!,"Sorry, another user currently editing this entry."
. . W !,"Try again later." D PAUSE^VALM1
. S DIE="^IBA(355.32,",DR=".04;2"
. D ^DIE S IBOUT=$D(Y)
. S DIE="^IBA(355.32,",DA=IBDA
. S DR="1.03///NOW;1.04////^S X=DUZ" D ^DIE ;Update user who edited entry
. L -^IBA(355.32,IBDA)
ADDX ;
;Rebuild the display
D HDR,INIT S VALMBCK="R",VALMBG=1
D PAUSE^VALM1
Q
;
EDIT ; ED Edit Coverage
D FULL^VALM1
N IBDA,IBEDIT,IBXX,IBREC,NEWARR,SAVARR,VALMY,X,Y
D EN^VALM2($G(XQORNOD(0)))
; Loop through entry(s) the user selected to Edit
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. K NEWARR,SAVARR
. S IBREC=$P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|")
. S IBDA=$P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|",2)
. ; save the current COVERAGE STATUS and LIMIT COMMENTS in order to determine
. ; if either of these fields were changed
. D GETS^DIQ(355.32,IBDA_",",".04;.05",,"SAVARR")
. ; check for the existence of an entry in file #355.32
. I $P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|",2)="" D Q
. . W !!,"** #"_IBXX_" "_$P(IBREC,U)_" - no data exist, use 'Add New Coverage' **",!
. W !!,"COVERAGE: "_$P(IBREC,U),?35,"for EFFECTIVE DATE: ",$P(IBREC,U,2)
. L +^IBA(355.32,IBDA):5 I '$T D LOCKED^IBTRCD1 Q
. ;if CONDITIONAL, add Limit Comments
. N DA,DIE,DR
. S DIE="^IBA(355.32,",DA=IBDA,DR=".04;2"
. D ^DIE
. ; save the current/potentially new COVERAGE STATUS and LIMIT COMMENTS
. ; field values to determine if these fields were updated, if so update
. ; fields #1.03 and 1.04
. S IBEDIT=0
. D GETS^DIQ(355.32,IBDA_",",".04;.05",,"NEWARR")
. I SAVARR(355.32,IBDA_",",.04)'=NEWARR(355.32,IBDA_",",.04) S IBEDIT=1
. I $G(SAVARR(355.32,IBDA_",",.05))'=$G(NEWARR(355.32,IBDA_",",.05)) S IBEDIT=1
. ; one of the fields were changed (IBEDIT=1), update the who and when last edited
. I IBEDIT=1 D
. . N DA,DIE,DR
. . S DIE="^IBA(355.32,",DA=IBDA,DR="1.03///NOW;1.04////^S X=DUZ"
. . D ^DIE
. L -^IBA(355.32,IBDA)
EDITX ;
;Rebuild the display
D HDR,INIT S VALMBCK="R",VALMBG=1
D PAUSE^VALM1
Q
;
DELETE ; DE Delete Coverage
D FULL^VALM1
N DELENT,IBXX,IBREC,STOP,VALMY
; builds the number range - Select Coverage Category(s): (1-9):
D EN^VALM2($G(XQORNOD(0)))
S STOP=0
; Loop through entry(s) the user selected for deletion
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
. ; check for the existence of an entry in file #355.32
. S IBREC=$P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|"),IBEFDT=$P(IBREC,U,2)
. I $P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|",2)="" W !!,"** #"_IBXX_" "_$P(IBREC,U)_" - no data exists, unable to delete **" Q
. N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
. W !
. S DIR(0)="Y",DIR("A")="Are you sure you want to delete #"_IBXX_" "_$P(IBREC,U)
. I IBEFDT'="" S DIR("A")=DIR("A")_" "_IBEFDT
. D ^DIR K DIR I Y="^" Q
. ;'No' was selected - don't delete entry
. I Y=0 W !,"#"_IBXX_" "_$P(IBREC,U)_" "_$S(IBEFDT'="":IBEFDT_" ",1:"")_"was NOT deleted" Q
. W !
. S DELENT=Y_U_Y(0)
. K DA,DIDEL
. S DA=$P($G(^TMP("IBCNSJ54X",$J,IBXX)),"|",2)
. S DIK="^IBA(355.32,",DIDEL=355.32
. D ^DIK K DIK
. W "#"_IBXX_" "_$P(IBREC,U)_" "_$S(IBEFDT'="":IBEFDT_" ",1:"")_"was deleted"
;
DELETEX ;
;Rebuild the display
D HDR,INIT S VALMBCK="R",VALMBG=1
D PAUSE^VALM1
Q
;
SORT ; ST Sort Coverage
N DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
D FULL^VALM1 W !
W !,"Select the item to sort the coverages on the screen."
S DIR(0)="SO^1:Coverage Category;2:Effective Date;3:Covered?"
S DIR("A")="Sort the list by"
S DIR("B")=$P($G(IBSORT),"^",2)
D ^DIR K DIR
I 'Y G SORTX
S IBSORT=Y_"^"_Y(0)
SORTX ;
; Rebuild the display based on the Sort selected
D HDR,INIT
S VALMBCK="R",VALMBG=1
Q
;========================Prompts, Checks, Warnings ==============================
;
SELED ; Prompt the user to enter a Effective Date
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
W !
S DIR(0)="DO",DIR("A")="Enter EFFECTIVE DATE"
D ^DIR W:$D(Y(0)) " ",Y(0) K DIR
I Y="^" S STOP=1 G SELEDX
S IBEDT=Y ;internal date - 3240101
I '$$PRECISE(DT,IBEDT) D SELEDP I STOP=1 G SELEDX
S IBEFDT=$$DAT3^IBOUTL(IBEDT) ;formatted date - 01/01/2024
SELEDX ;
Q
;
SELEDP ; Enter a precise Effective Date
N DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
W !
S DIR("A")="Enter a new precise EFFECTIVE DATE "_$$DAT3^IBOUTL(IBEDT)
S DIR("A",1)="You have entered an imprecise date. You must enter a precise date"
S DIR("A",2)="to edit/add a Coverage Limitation."
S DIR("A",4)=""
S DIR(0)="D^::EX"
D ^DIR K DIR I Y="^" S STOP=1 Q
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S DONE=1 Q
S IBEDT=Y
Q
;
SELCC ; Prompt to allow users to include one or more Coverage Category(s)
N A,DIR,DIRUT,I,X,Y
K IBCCAT
S IBCCAT="",END=$O(^IBE(355.31,9999999),-1)
W !,"Select COVERAGE CATEGORIES:"
S DIR(0)="L^0:"_END
S DIR("A",1)=" 0 - ALL"
F A=2:1:(END+1) S IEN=A-1 S DIR("A",A)=" "_IEN_" - "_$P(^IBE(355.31,IEN,0),U)
S DIR("A")="Select one or more Coverage Categories"
S DIR("?",1)=" Please select one or more Coverage Categories separated by a coma."
S DIR("?")=" Example: enter 1,3 to select Inpatient and Pharmacy"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT)!(Y="^") S STOP=1 G SELCCX
I Y[("0") S IBCCAT=0 G SELCCX ; IBCCAT=0 - ALL categories
; build IBCCAT array of what the user selected
F I=1:1 Q:'$P(Y,",",I) S IBCCAT(I)=$P(Y,",",I)
SELCCX ; SELCC exit pt
Q
;
EXISTS(IBCPOL,IBEDT) ; Check to see if there is an entry category and date.
N EXISTS,IBTYP
S EXISTS=0
S IBTYP=IBCCAT(I) ; get the category
; Found a category with this date set EXISTS=1
I $D(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT)) S EXISTS=1
Q EXISTS
;
PRECISE(X1,X2) ;Check to make sure the date entered is a precise date
;Returns: 0=imprecise date / 1=precise date
N %Y
D ^%DTC
Q %Y
;
CHKEDT(IBTYP) ; Check for effective date later than the one entered
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"
. S DIR("A",2)="already exists for "_$P($G(^IBE(355.31,IBTYP,0)),U)_"."
. S DIR("A")=" Are you sure you want to add this earlier date for the category"
. S DIR("B")="NO"
. D ^DIR K DIR
. W !
Q (Y=1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ54 14268 printed Aug 26, 2025@22:33:21 Page 2
IBCNSJ54 ;AITC/CKB - INSURANCE PLAN MAINTENANCE ACTION COVERAGE LIMITS ; 02-OCT-2024
+1 ;;2.0;INTEGRATED BILLING;**804**;21-MAR-94;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
EN ; -- main entry point for ADD/EDIT COVERAGE
+1 SET VALMBCK="R"
SET VALMBG=1
SET VALMCNT=0
+2 SET IBSORT="1^Coverage Category"
+3 DO EN^VALM("IBCNS ADD/EDIT COVERAGE")
+4 QUIT
+5 ;
HDR ; -- header code
+1 NEW COVFN,GIENS,GIND,GINACT,GNAME,GNUM,IBCBY,IBCDT,LASTUPD,LSTBY,LSTDT
+2 DO GRPHDR
+3 SET VALMHDR(1)="Group Name: "_GNAME
SET $EXTRACT(VALMHDR(1),40,79)="Group Number: "_GNUM
+4 ;LASTUPD = COVERAGE Last Updated <date> by <who>
+5 SET VALMHDR(2)=LASTUPD
+6 SET VALMHDR(3)="Sorted by: "_$SELECT(IBSORT'="":$PIECE(IBSORT,U,2),1:"Coverage Category")
+7 SET VALMHDR(4)=" "
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 ; Initialize variables and list array
+2 ; Input: None
+3 ; Output: ^TMP("IBCNSJ54",$J) - Body lines to display
+4 KILL ^TMP("IBCNSJ54",$JOB),^TMP("IBCNSJ54X"),^TMP($JOB,"IBCNSJ54")
+5 if $GET(IBSORT)=""
SET IBSORT="1^Coverage Category"
+6 DO BLD
+7 QUIT
+8 ;
GRPHDR ; Get GROUP PLAN HEADER info
+1 ;Get Group Name and Group Number
+2 ; IBCPOL - IEN in the GROUP INSURANCE PLAN file #355.3
+3 NEW IB3553,IBARR,IBCPOL1
+4 KILL IBARR,IB3553
+5 SET IBCPOL1=IBCPOL_","
+6 DO GETS^DIQ(355.3,IBCPOL1,".1;.11;2.01;2.02","EI","IBARR")
MERGE IB3553=IBARR(355.3,IBCPOL1)
+7 SET GIND=$GET(IB3553(.1,"I"))
SET GINACT=$GET(IB3553(.11,"I"))
+8 SET GNAME=$GET(IB3553(2.01,"E"))
SET GNUM=$GET(IB3553(2.02,"E"))
+9 if GNAME=""
SET GNAME="<NO GROUP NAME>"
if GNUM=""
SET GNUM="<NO GROUP NUMBER>"
+10 ; Add '+'=individual and/or '*'=inactive
+11 IF GIND'=""
SET GNAME="+"_GNAME
+12 IF GINACT
SET GNUM="*"_GNUM
+13 ;Get COVERAGE Last Updated <date> by <who>
+14 SET LASTUPD="COVERAGE Last Updated by "
+15 IF $DATA(^IBA(355.32,"LAST",IBCPOL))
Begin DoDot:1
+16 SET IBCDT=$ORDER(^IBA(355.32,"LAST",IBCPOL,""))
SET IBCBY=$ORDER(^IBA(355.32,"LAST",IBCPOL,IBCDT,""))
+17 SET COVFN=$ORDER(^IBA(355.32,"LAST",IBCPOL,IBCDT,IBCBY,""))
SET GIENS=COVFN_","
+18 SET LSTDT=$$GET1^DIQ(355.32,GIENS,1.03,"I")
SET LSTBY=$$GET1^DIQ(355.32,GIENS,1.04,"E")
+19 SET LASTUPD="COVERAGE Last Updated "_$$FO^IBCNEUT1($$FMTE^XLFDT(LSTDT,"5Z"),10)_" by "_LSTBY
End DoDot:1
+20 QUIT
+21 ;
BLD ; Build listman display
+1 ; IBCPOL - IEN in the GROUP INSURANCE PLAN file #355.3
+2 ; IBSORT - order of the Coverages dislayed on the screen
+3 ; VALMCNT - Total number of lines displayed in the body
+4 ;
+5 ; ^TMP("IBCNSJ54",$J) - contains the lines to be displayed
+6 ; ^TMP("IBCNSJ54X",$J) - IEN file #55.32 ^ Coverage Category ^ Eff Date ^ Covered? ^ Limit Comment
+7 ; ^TMP($J,"IBCNSJ54") - contains the sorted output
+8 ;
+9 ; Build display of a Group Plan Coverage data
+10 NEW CATARR,CDATA,CTR,GINACT,GIND,GNAME,GNUM,GTYP,I,IBCAT,IBCCAT,IBCOV,IBCSTA,IBDT,IBCVREC
+11 NEW IBEDT,IBEFDT,IBLIMCOM,IBRECDT,IBREC,IBRECN,ICTR,LINE,RTN
+12 KILL ^TMP("IBCNSJ54",$JOB),^TMP("IBCNSJ54X")
+13 KILL ^TMP($JOB,"IBCNSJ54")
+14 SET (ICTR,VALMCNT)=0
+15 SET RTN="IBCNSJ54"
+16 ; Compile Plan Coverage Limitation info
+17 ; File# 355.31 PLAN LIMITATION CATEGORY contains ALL coverage categories
+18 FOR I=1:1:$ORDER(^IBE(355.31,"B"),-1)
SET IBCAT=I
Begin DoDot:1
+19 KILL IBEDT,IBCSTA,IBCVREC,IBRECN
+20 ; If the Category doesn't exist for the Plan the Coverage Status is BY DEFAULT
+21 IF '$DATA(^IBA(355.32,"APCD",IBCPOL,I))
Begin DoDot:2
+22 SET IBCAT=I
SET IBRECN=""
SET IBEDT=0
+23 ; Coverage Status
SET IBCSTA="BY DEFAULT"
+24 ; Coverage Category
SET IBCOV=$$GET1^DIQ(355.31,I,.01,"E")
+25 SET IBCVREC=IBCOV_U_U_IBCSTA
+26 SET ICTR=ICTR+1
+27 ; SORT BY: 1-Coverage / 2-Effective Date / 3-Covered?
+28 IF $PIECE(IBSORT,U)=1
SET ^TMP($JOB,RTN,IBCAT,-IBEDT,IBCSTA)=IBCVREC_"|"_IBRECN
+29 IF $PIECE(IBSORT,U)=2
SET ^TMP($JOB,RTN,-IBEDT,IBCAT,IBCSTA)=IBCVREC_"|"_IBRECN
+30 IF $PIECE(IBSORT,U)=3
SET ^TMP($JOB,RTN,IBCSTA,IBCAT,-IBEDT)=IBCVREC_"|"_IBRECN
End DoDot:2
QUIT
+31 SET IBRECDT=""
+32 FOR
SET IBRECDT=$ORDER(^IBA(355.32,"APCD",IBCPOL,IBCAT,IBRECDT))
if IBRECDT=""
QUIT
Begin DoDot:2
+33 SET IBRECN=""
+34 FOR
SET IBRECN=$ORDER(^IBA(355.32,"APCD",IBCPOL,IBCAT,IBRECDT,IBRECN))
if IBRECN=""
QUIT
Begin DoDot:3
+35 ; Coverage Category
SET IBCOV=$$GET1^DIQ(355.32,IBRECN,.02)
+36 SET IBEDT=$$GET1^DIQ(355.32,IBRECN,.03,"I")
+37 ; Effective Date
SET IBEFDT=$$DAT3^IBOUTL(IBEDT)
+38 ; Coverage Status
SET IBCSTA=$$GET1^DIQ(355.32,IBRECN,.04,"I")
+39 SET IBCSTA=$SELECT(IBCSTA="":"BY DEFAULT",IBCSTA=0:"NO",IBCSTA=1:"YES",1:"CONDITIONAL")
+40 ; Limit Comments?
SET IBLIMCOM=""
DO LIMCOM
+41 SET IBCVREC=IBCOV_U_IBEFDT_U_IBCSTA_U_IBLIMCOM
+42 SET ICTR=ICTR+1
+43 ; SORT BY: 1-Coverage / 2-Effective Date / 3-Covered?
+44 IF $PIECE(IBSORT,U)=1
SET ^TMP($JOB,RTN,IBCAT,-IBEDT,IBCSTA)=IBCVREC_"|"_IBRECN
+45 IF $PIECE(IBSORT,U)=2
SET ^TMP($JOB,RTN,-IBEDT,IBCAT,IBCSTA)=IBCVREC_"|"_IBRECN
+46 IF $PIECE(IBSORT,U)=3
SET ^TMP($JOB,RTN,IBCSTA,IBCAT,-IBEDT)=IBCVREC_"|"_IBRECN
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;
+48 ; Loop through the sorted data and build the lines to be displayed
+49 NEW LINE,SCT,SORT1,SORT2,SORT3,SREC,SRECN
+50 SET SCT=0
+51 SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,RTN,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+52 SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,RTN,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+53 SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,RTN,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
SET SCT=SCT+1
Begin DoDot:3
+54 SET SREC=$PIECE(^TMP($JOB,RTN,SORT1,SORT2,SORT3),"|")
+55 SET SRECN=$PIECE(^TMP($JOB,RTN,SORT1,SORT2,SORT3),"|",2)
+56 SET LINE=$$BLDLN(SCT,SREC)
+57 SET VALMCNT=VALMCNT+1
+58 ; SRECN = IEN of the entry in file #355.32 - needed for Edit & Delete
+59 SET ^TMP("IBCNSJ54X",$JOB,VALMCNT)=SREC_"|"_SRECN
+60 DO SET^VALM10(VALMCNT,LINE,LINE)
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 SET VALMBCK="R"
SET VALMBG=1
+63 QUIT
+64 ;
LIMCOM ;Limitation Comments from the multiple - include ALL comments
+1 KILL IBLIMCOM
SET IBLIMCOM=""
+2 NEW Z
+3 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.32,IBRECN,2,Z))
if 'Z!(Z="")
QUIT
IF $GET(^IBA(355.32,IBRECN,2,Z,0))'=""
Begin DoDot:1
+4 ; Append all the comments together separated by a <space>
+5 SET IBLIMCOM=IBLIMCOM_^IBA(355.32,IBRECN,2,Z,0)_" "
End DoDot:1
+6 QUIT
+7 ;
HELP ; -- help code
+1 IF $GET(VALMANS)="??"
SET X="?"
DO DISP^XQORM1
WRITE !!
QUIT
+2 DO FULL^VALM1
+3 NEW DIR,X,Y
+4 WRITE !!," Enter AD to Add New Coverage."
+5 WRITE !," Enter ED to Edit Coverage."
+6 WRITE !," Enter DE to Delete Coverage."
+7 WRITE !," Enter ST to Sort List.",!
+8 SET DIR(0)="E"
SET DIR("A")="Press <Enter> to return to Add/Edit Coverage"
+9 DO ^DIR
+10 KILL DIR,X,Y
+11 SET VALMBCK="R"
SET VALMBG=1
+12 QUIT
+13 ;
EXIT ; -- exit code
+1 KILL IBSORT,^TMP("IBCNSJ54",$JOB),^TMP("IBCNSJ54X"),^TMP($JOB,"IBCNSJ54")
+2 DO CLEAN^VALM10
DO CLEAR^VALM1
+3 SET VALMBCK="R"
SET VALMBG=1
+4 QUIT
+5 ;
BLDLN(ICTR,IREC) ; Builds a line to display one insurance company
+1 ; Input: ICTR - Selection Number
+2 ; IREC - the Coverage data to be displayed
+3 ; Output: LINE - formatted for setting into the list display
+4 NEW LINE
+5 ; Selection #
SET LINE=$$SETSTR^VALM1(ICTR,"",1,4)
+6 ; Category Coverage
SET LINE=$$SETSTR^VALM1($PIECE(IREC,U),LINE,5,15)
+7 ; Effective Date
SET LINE=$$SETSTR^VALM1($PIECE(IREC,U,2),LINE,23,10)
+8 ; Covered?
SET LINE=$$SETSTR^VALM1($PIECE(IREC,U,3),LINE,40,11)
+9 ; Limit Comments
SET LINE=$$SETSTR^VALM1($PIECE(IREC,U,4),LINE,54,75)
+10 QUIT LINE
+11 ;
ADD ; AD Add Coverage
+1 NEW DONE,END,I,IBCCAT,IBCOV,IEN,NOW,STOP
+2 DO FULL^VALM1
+3 SET STOP=0
+4 ; prompt for the Effective Date
+5 DO SELED
IF $GET(IBEFDT)="^"!($GET(STOP)=1)
GOTO ADDX
+6 ; prompt for Coverage Category(s)
+7 DO SELCC
IF STOP=1
GOTO ADDX
+8 ; if ALL was selected build IBCCAT array
+9 IF $GET(IBCCAT)=0
FOR I=1:1:END
SET IBCCAT(I)=I
+10 ;Loop through the IBCCAT array
+11 FOR I=1:1
if '$DATA(IBCCAT(I))
QUIT
Begin DoDot:1
+12 NEW COVCAT,IBDA,IBOUT
+13 SET COVCAT=^IBE(355.31,IBCCAT(I),0)
+14 WRITE !!,$PIECE(COVCAT,U)
+15 ; check for existence of this Effective Date & Coverage Category
+16 IF $$EXISTS(IBCPOL,IBEDT)
Begin DoDot:2
+17 WRITE !,"** "_$PIECE(COVCAT,U)_" - data already exist for this Effective Date, nothing added **",!
QUIT
End DoDot:2
QUIT
+18 ; Check for effective date later than the one you entered
+19 ; if found ask "Are you sure you want to add this earlier date for the category? NO//" 0-NO 1-YES
+20 IF '$$CHKEDT(IBCCAT(I))
QUIT
+21 KILL DIC,DO,DD
+22 SET DIC="^IBA(355.32,"
SET DIC(0)="L"
SET X=IBCPOL
SET DIC("DR")=".02///"_$PIECE(COVCAT,U)_";.03///"_IBEDT_";.04////1"
+23 DO FILE^DICN
+24 SET DA=$SELECT(Y>0:+Y,1:0)
+25 SET IBDA=DA
+26 ;
+27 LOCK +^IBA(355.32,IBDA):5
IF '$TEST
Begin DoDot:2
+28 WRITE !!,"Sorry, another user currently editing this entry."
+29 WRITE !,"Try again later."
DO PAUSE^VALM1
End DoDot:2
QUIT
+30 SET DIE="^IBA(355.32,"
SET DR=".04;2"
+31 DO ^DIE
SET IBOUT=$DATA(Y)
+32 SET DIE="^IBA(355.32,"
SET DA=IBDA
+33 ;Update user who edited entry
SET DR="1.03///NOW;1.04////^S X=DUZ"
DO ^DIE
+34 LOCK -^IBA(355.32,IBDA)
End DoDot:1
ADDX ;
+1 ;Rebuild the display
+2 DO HDR
DO INIT
SET VALMBCK="R"
SET VALMBG=1
+3 DO PAUSE^VALM1
+4 QUIT
+5 ;
EDIT ; ED Edit Coverage
+1 DO FULL^VALM1
+2 NEW IBDA,IBEDIT,IBXX,IBREC,NEWARR,SAVARR,VALMY,X,Y
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 ; Loop through entry(s) the user selected to Edit
+5 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+6 KILL NEWARR,SAVARR
+7 SET IBREC=$PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|")
+8 SET IBDA=$PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|",2)
+9 ; save the current COVERAGE STATUS and LIMIT COMMENTS in order to determine
+10 ; if either of these fields were changed
+11 DO GETS^DIQ(355.32,IBDA_",",".04;.05",,"SAVARR")
+12 ; check for the existence of an entry in file #355.32
+13 IF $PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|",2)=""
Begin DoDot:2
+14 WRITE !!,"** #"_IBXX_" "_$PIECE(IBREC,U)_" - no data exist, use 'Add New Coverage' **",!
End DoDot:2
QUIT
+15 WRITE !!,"COVERAGE: "_$PIECE(IBREC,U),?35,"for EFFECTIVE DATE: ",$PIECE(IBREC,U,2)
+16 LOCK +^IBA(355.32,IBDA):5
IF '$TEST
DO LOCKED^IBTRCD1
QUIT
+17 ;if CONDITIONAL, add Limit Comments
+18 NEW DA,DIE,DR
+19 SET DIE="^IBA(355.32,"
SET DA=IBDA
SET DR=".04;2"
+20 DO ^DIE
+21 ; save the current/potentially new COVERAGE STATUS and LIMIT COMMENTS
+22 ; field values to determine if these fields were updated, if so update
+23 ; fields #1.03 and 1.04
+24 SET IBEDIT=0
+25 DO GETS^DIQ(355.32,IBDA_",",".04;.05",,"NEWARR")
+26 IF SAVARR(355.32,IBDA_",",.04)'=NEWARR(355.32,IBDA_",",.04)
SET IBEDIT=1
+27 IF $GET(SAVARR(355.32,IBDA_",",.05))'=$GET(NEWARR(355.32,IBDA_",",.05))
SET IBEDIT=1
+28 ; one of the fields were changed (IBEDIT=1), update the who and when last edited
+29 IF IBEDIT=1
Begin DoDot:2
+30 NEW DA,DIE,DR
+31 SET DIE="^IBA(355.32,"
SET DA=IBDA
SET DR="1.03///NOW;1.04////^S X=DUZ"
+32 DO ^DIE
End DoDot:2
+33 LOCK -^IBA(355.32,IBDA)
End DoDot:1
EDITX ;
+1 ;Rebuild the display
+2 DO HDR
DO INIT
SET VALMBCK="R"
SET VALMBG=1
+3 DO PAUSE^VALM1
+4 QUIT
+5 ;
DELETE ; DE Delete Coverage
+1 DO FULL^VALM1
+2 NEW DELENT,IBXX,IBREC,STOP,VALMY
+3 ; builds the number range - Select Coverage Category(s): (1-9):
+4 DO EN^VALM2($GET(XQORNOD(0)))
+5 SET STOP=0
+6 ; Loop through entry(s) the user selected for deletion
+7 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+8 ; check for the existence of an entry in file #355.32
+9 SET IBREC=$PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|")
SET IBEFDT=$PIECE(IBREC,U,2)
+10 IF $PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|",2)=""
WRITE !!,"** #"_IBXX_" "_$PIECE(IBREC,U)_" - no data exists, unable to delete **"
QUIT
+11 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+12 WRITE !
+13 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete #"_IBXX_" "_$PIECE(IBREC,U)
+14 IF IBEFDT'=""
SET DIR("A")=DIR("A")_" "_IBEFDT
+15 DO ^DIR
KILL DIR
IF Y="^"
QUIT
+16 ;'No' was selected - don't delete entry
+17 IF Y=0
WRITE !,"#"_IBXX_" "_$PIECE(IBREC,U)_" "_$SELECT(IBEFDT'="":IBEFDT_" ",1:"")_"was NOT deleted"
QUIT
+18 WRITE !
+19 SET DELENT=Y_U_Y(0)
+20 KILL DA,DIDEL
+21 SET DA=$PIECE($GET(^TMP("IBCNSJ54X",$JOB,IBXX)),"|",2)
+22 SET DIK="^IBA(355.32,"
SET DIDEL=355.32
+23 DO ^DIK
KILL DIK
+24 WRITE "#"_IBXX_" "_$PIECE(IBREC,U)_" "_$SELECT(IBEFDT'="":IBEFDT_" ",1:"")_"was deleted"
End DoDot:1
+25 ;
DELETEX ;
+1 ;Rebuild the display
+2 DO HDR
DO INIT
SET VALMBCK="R"
SET VALMBG=1
+3 DO PAUSE^VALM1
+4 QUIT
+5 ;
SORT ; ST Sort Coverage
+1 NEW DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
+2 DO FULL^VALM1
WRITE !
+3 WRITE !,"Select the item to sort the coverages on the screen."
+4 SET DIR(0)="SO^1:Coverage Category;2:Effective Date;3:Covered?"
+5 SET DIR("A")="Sort the list by"
+6 SET DIR("B")=$PIECE($GET(IBSORT),"^",2)
+7 DO ^DIR
KILL DIR
+8 IF 'Y
GOTO SORTX
+9 SET IBSORT=Y_"^"_Y(0)
SORTX ;
+1 ; Rebuild the display based on the Sort selected
+2 DO HDR
DO INIT
+3 SET VALMBCK="R"
SET VALMBG=1
+4 QUIT
+5 ;========================Prompts, Checks, Warnings ==============================
+6 ;
SELED ; Prompt the user to enter a Effective Date
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+2 WRITE !
+3 SET DIR(0)="DO"
SET DIR("A")="Enter EFFECTIVE DATE"
+4 DO ^DIR
if $DATA(Y(0))
WRITE " ",Y(0)
KILL DIR
+5 IF Y="^"
SET STOP=1
GOTO SELEDX
+6 ;internal date - 3240101
SET IBEDT=Y
+7 IF '$$PRECISE(DT,IBEDT)
DO SELEDP
IF STOP=1
GOTO SELEDX
+8 ;formatted date - 01/01/2024
SET IBEFDT=$$DAT3^IBOUTL(IBEDT)
SELEDX ;
+1 QUIT
+2 ;
SELEDP ; Enter a precise Effective Date
+1 NEW DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
+2 WRITE !
+3 SET DIR("A")="Enter a new precise EFFECTIVE DATE "_$$DAT3^IBOUTL(IBEDT)
+4 SET DIR("A",1)="You have entered an imprecise date. You must enter a precise date"
+5 SET DIR("A",2)="to edit/add a Coverage Limitation."
+6 SET DIR("A",4)=""
+7 SET DIR(0)="D^::EX"
+8 DO ^DIR
KILL DIR
IF Y="^"
SET STOP=1
QUIT
+9 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET DONE=1
QUIT
+10 SET IBEDT=Y
+11 QUIT
+12 ;
SELCC ; Prompt to allow users to include one or more Coverage Category(s)
+1 NEW A,DIR,DIRUT,I,X,Y
+2 KILL IBCCAT
+3 SET IBCCAT=""
SET END=$ORDER(^IBE(355.31,9999999),-1)
+4 WRITE !,"Select COVERAGE CATEGORIES:"
+5 SET DIR(0)="L^0:"_END
+6 SET DIR("A",1)=" 0 - ALL"
+7 FOR A=2:1:(END+1)
SET IEN=A-1
SET DIR("A",A)=" "_IEN_" - "_$PIECE(^IBE(355.31,IEN,0),U)
+8 SET DIR("A")="Select one or more Coverage Categories"
+9 SET DIR("?",1)=" Please select one or more Coverage Categories separated by a coma."
+10 SET DIR("?")=" Example: enter 1,3 to select Inpatient and Pharmacy"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="^")
SET STOP=1
GOTO SELCCX
+13 ; IBCCAT=0 - ALL categories
IF Y[("0")
SET IBCCAT=0
GOTO SELCCX
+14 ; build IBCCAT array of what the user selected
+15 FOR I=1:1
if '$PIECE(Y,",",I)
QUIT
SET IBCCAT(I)=$PIECE(Y,",",I)
SELCCX ; SELCC exit pt
+1 QUIT
+2 ;
EXISTS(IBCPOL,IBEDT) ; Check to see if there is an entry category and date.
+1 NEW EXISTS,IBTYP
+2 SET EXISTS=0
+3 ; get the category
SET IBTYP=IBCCAT(I)
+4 ; Found a category with this date set EXISTS=1
+5 IF $DATA(^IBA(355.32,"APCD",+IBCPOL,IBTYP,-IBEDT))
SET EXISTS=1
+6 QUIT EXISTS
+7 ;
PRECISE(X1,X2) ;Check to make sure the date entered is a precise date
+1 ;Returns: 0=imprecise date / 1=precise date
+2 NEW %Y
+3 DO ^%DTC
+4 QUIT %Y
+5 ;
CHKEDT(IBTYP) ; Check for effective date later than the one entered
+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"
+6 SET DIR("A",2)="already exists for "_$PIECE($GET(^IBE(355.31,IBTYP,0)),U)_"."
+7 SET DIR("A")=" Are you sure you want to add this earlier date for the category"
+8 SET DIR("B")="NO"
+9 DO ^DIR
KILL DIR
+10 WRITE !
End DoDot:1
+11 QUIT (Y=1)
