IBCNSUR4.m

IBCNSUR4 ;ALB/VD - SELECT MULTIPLE SUBSCRIBERS LOOK-UP UTILITY ; 14-APR-15

 ;;2.0;INTEGRATED BILLING;**549**;14-APR-15;Build 54

 ;;Per VA Directive 6402, this routine should not be modified.

 ;;

 ;

EN(IBC1,IBP1,IBDD,IBSBID,IBVAL,IBSUBACT,IBEFDT,IBEFDT1,IBEFDT2) ; Entry Point

 ; Look-up Utility to Select Multiple Subscribers

 ;  Input:  IBC1    --  Pointer to the company in file #36

 ;          IBP1    --  Pointer to the plan in file #355.3

 ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 ;                      Deceased, 0 - Ignore Deceased)

 ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 ;          IBSUBACT --  Subscriber Filter for Active Indicator (0 - Ignore

 ;                      Active Status, 1 - Filter Active, 2 - Filter Inactive)

 ;                      to be excluded from selection

 ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 ;          IBEFDT1 --  Effective Date Filter Start Date.

 ;          IBEFDT2 --  Effective Date Filter End Date.

 ;

 ; Output:  IBCNT  --  Number of Subscriber Policies to Move.

 ;          ^TMP("IBCNSUR4A,$J) - Array of selected Subscribers.

 D EN^VALM("IBCN SUBSCRIBER SELECTOR")

 I +$G(IBFASTXT) S IBQUIT=1

 Q +$G(NUMSEL)_U_+$G(IBSUB)

 ;

HDR(SELECTED) ;EP

 ; Header code for the Subscriber Selection template

 ;  Input:  SELECTED -- 1=Showing header for selected listman

 ;                      0=Is the default or optional value

 ;

 ;          IBC1    --  Pointer to the company in file #36

 ;          IBP1    --  Pointer to the plan in file #355.3

 ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 ;                      Deceased, 0 - Ignore Deceased)

 ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 ;          IBSUBACT -- Subscriber Filter for Active Indicator (0 - Ignore

 ;                      Active Status, 1 - Filter Active, 2 - Filter Inactive)

 ;                      to be excluded from selection

 ;          IBACTV  --  List of Active or Inactive policies.

 ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 ;          IBEFDT1 --  Effective Date Filter Start Date.

 ;          IBEFDT2 --  Effective Date Filter End Date.

 ;

 ; Output:  VALMHDR --  Header information to display

 N HCTR

 S:$G(IBSORT)="" IBSORT="1^Patient Name"

 S VALMHDR(1)="Subscribers in: "_$$GET1^DIQ(36,+IBC1,.01),$E(VALMHDR(1),50,79)="Grp Name: "_$$GET1^DIQ(355.3,+IBP1,.03)

 S VALMHDR(2)=$E($$GET1^DIQ(36,+IBC1,.111),1,20)_"  "_$E($$GET1^DIQ(36,+IBC1,.114),1,20)   ; Address and City

 S VALMHDR(2)=VALMHDR(2)_", "_$P($G(^DIC(5,+$$GET1^DIQ(36,+IBC1,.115,"I"),0)),U,2)_" "_$E($$GET1^DIQ(36,+IBC1,.116),1,5)  ; ST Zip.

 S $E(VALMHDR(2),53,99)="Grp #: "_$$GET1^DIQ(355.3,+IBP1,.04)

 ;

 S VALMHDR(3)=+$G(NUMSEL)_" Subscriber"_$S(+$G(NUMSEL)=1:"",1:"s")_" selected out of "_+$G(IBSUB),$E(VALMHDR(3),50,99)="Sorted by: "_$P(IBSORT,U,2)

 S HCTR=4

 S VALMHDR(HCTR)="Filters: "_$S(IBDD=1:"Living PATs",1:"All PATs")

 I $L(IBVAL) S VALMHDR(HCTR)=VALMHDR(HCTR)_", SubIDs w/'"_IBVAL_"'"

 I $L(VALMHDR(HCTR))>57 S HCTR=HCTR+1

 I '$D(VALMHDR(HCTR)) S VALMHDR(HCTR)="        "

 S VALMHDR(HCTR)=VALMHDR(HCTR)_$S(IBSUBACT=1:", Active",IBSUBACT=2:", Inactive",IBSUBACT=3:", All",1:$S(+IBSUBACT:"",1:", All"))_" Policies"

 I $L(VALMHDR(HCTR))>46 S HCTR=HCTR+1

 I +IBEFDT D

 . I '$D(VALMHDR(HCTR)) S VALMHDR(HCTR)="        "

 . S VALMHDR(HCTR)=VALMHDR(HCTR)_", Eff "_$$DAT1^IBOUTL(IBEFDT1)_"-"_$$DAT1^IBOUTL(IBEFDT2)

 Q

 ;

INIT ;EP

 ; Initialize variables and list array

 ; Input: None

 ; Output:  ^TMP("IBCNSUR4",$J) - Body lines to display

 K ^TMP("IBCNSUR4",$J),^TMP("IBCNSUR4IX",$J),^TMP("IBCNSUR4A",$J)

 S:$G(IBSORT)="" IBSORT="1^Patient Name"

 D BLD

 Q

 ;

BLD ; Build listman body

 ;  Input:  IBC1    --  Pointer to the company in file #36

 ;          IBP1    --  Pointer to the plan in file #355.3

 ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 ;                      Deceased, 0 - Ignore Deceased)

 ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 ;          IBSUBACT -- Subscriber Filter for Active Indicator (0 - Include

 ;                      Both Active & Inactive, 1 - Include Active,

 ;                      2 - Include Inactive) to be included in selection.

 ;          IBACTV  --  List of Active or Inactive policies.

 ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 ;          IBEFDT1 --  Effective Date Filter Start Date.

 ;          IBEFDT2 --  Effective Date Filter End Date.

 ; Output:  VALMCNT   - Total number of lines displayed in the body

 ;          ^TMP("IBCNSUR4",$J)   - Body lines to display

 ;          ^TMP("IBCNSUR4IX",$J) - Index of Entry IENs by display line

 ;

 N ACTIVE,CURCNT,DFN,DFNY,OMIT,PATEFF,PATEXP,PATID,PATNAM,PATSID,PATSSN,PATWHO

 N SORTED,SRTKEY1,SRTKEY2,SRTKEY3,SRTREC,Y

 S IBSUB=$$SUBS^IBCNSJ(IBC1,IBP1,0,"^TMP($J,""IBCNSURS"")")

 S (CURCNT,VALMCNT)=0

 I '+IBSUB S ^TMP("IBCNSUR4",$J,1,0)="*  This group plan has no subscribers!" Q

 I IBSUB D

 . S DFN=""

 . F  S DFN=$O(^TMP($J,"IBCNSURS",DFN)) Q:DFN=""  D

 . . S Y=""

 . . F  S Y=$O(^TMP($J,"IBCNSURS",DFN,Y)) Q:Y=""  D

 . . . S OMIT=0,DFNY=DFN_"~"_Y

 . . . D GTSREC(DFNY,.SRTREC)

 . . . S PATSID=$P(SRTREC,U,2),PATEFF=$P(SRTREC,U,3),PATEXP=$P(SRTREC,U,4)

 . . . S ACTIVE=$S('PATEXP:1,DT>+PATEXP:0,1:1)

 . . . I +IBDEAD,+$$GET1^DIQ(2,DFN_",",.351,"I") Q   ; If ignoring deceased and subscriber is deceased exclude.

 . . . I +IBSUBID,$L(IBVALUE),($$UP^XLFSTR(PATSID)'[IBVALUE) Q    ; Sub ID doesn't contain the Sub ID screen exclude.

 . . . I +IBSUBACT D  Q:OMIT      ; Active vs Inactive

 . . . . I IBSUBACT=1,'ACTIVE S OMIT=1 Q  ; Include active Policies.

 . . . . I IBSUBACT=2,+ACTIVE S OMIT=1    ; Include inactive Policies.

 . . . I +IBEFDT D  Q:OMIT        ; Effective Date

 . . . . I PATEFF<IBEFDT1 S OMIT=1 Q    ; Effective date is less than starting date.

 . . . . I PATEFF>IBEFDT2 S OMIT=1      ; Effective date is less than ending date.

 . . . I '$D(IBSORT) S IBSORT=1

 . . . S SRTKEY1=$P(SRTREC,U,IBSORT)

 . . . S SRTKEY2=$P(SRTREC,U,1)   ; PATNAM

 . . . S SRTKEY3=$O(SORTED(SRTKEY1,SRTKEY2,""),-1)+1

 . . . S SORTED(SRTKEY1,SRTKEY2,SRTKEY3)=SRTREC

 . . . ;

 . S SRTKEY1=""

 . F  S SRTKEY1=$O(SORTED(SRTKEY1)) Q:SRTKEY1=""  D

 . . S SRTKEY2=""

 . . F  S SRTKEY2=$O(SORTED(SRTKEY1,SRTKEY2)) Q:SRTKEY2=""  D

 . . . S SRTKEY3=""

 . . . F  S SRTKEY3=$O(SORTED(SRTKEY1,SRTKEY2,SRTKEY3)) Q:SRTKEY3=""  D

 . . . . S SRTREC=SORTED(SRTKEY1,SRTKEY2,SRTKEY3)

 . . . . S DFNY=$P(SRTREC,U,8),DFN=$P(DFNY,"~",1),Y=$P(DFNY,"~",2)

 . . . . S CURCNT=CURCNT+1

 . . . . S LINE=$$BLDLN(CURCNT,DFN,Y,SRTREC)

 . . . . S VALMCNT=VALMCNT+1

 . . . . D SET^VALM10(VALMCNT,LINE,LINE)

 . . . . S ^TMP("IBCNSUR4IX",$J,CURCNT)=DFNY

 I IBSUB S IBSUB=CURCNT

 I VALMCNT=0 D

 . S ^TMP("IBCNSUR4",$J,1,0)="No Subscribers with Selection Criteria were found."

 Q

 ;

GTSREC(DFNY,SRTREC) ; Get the sort record data

 N DFN,PATEFF,PATEXP,PATID,PATNAM,PATSID,PATSSN,PATWHO,Y

 S SRTREC=""

 S DFN=$P(DFNY,"~",1),Y=$P(DFNY,"~",2)

 S PATNAM=$$GET1^DIQ(2,DFN_",",.01),PATNAM=$S($L(PATNAM):PATNAM,1:" ")

 S PATSSN=$E($$GET1^DIQ(2,DFN_",",.09),6,9),PATSSN=$S($L(PATSSN):PATSSN,1:" ")

 S PATSID=$E($$GET1^DIQ(2.312,Y_","_DFN_",",7.02),1,20),PATSID=$S($L(PATSID):PATSID,1:" ")   ;Only use the 1st 20 chars of SUBID.

 S PATEFF=$$GET1^DIQ(2.312,Y_","_DFN_",",8,"I"),PATEFF=$S($L(PATEFF):PATEFF,1:" ")

 S PATEXP=$$GET1^DIQ(2.312,Y_","_DFN_",",3,"I"),PATEXP=$S($L(PATEXP):PATEXP,1:" ")

 S PATWHO=$$GET1^DIQ(2.312,Y_","_DFN_",",6),PATWHO=$S('$L(PATWHO):"UNK",1:$E(PATWHO,1,3))

 S PATID=$$GET1^DIQ(2.312,Y_","_DFN_",",5.01),PATID=$S($L(PATID):PATID,1:" ")

 S SRTREC=PATNAM_U_PATSID_U_PATEFF_U_PATEXP_U_PATWHO_U_PATID_U_PATSSN_U_DFNY

 Q

 ;

BLDLN(ICTR,DFN,Y,SRTREC) ;EP

 ; Also called from BLD^IBCNEILK2

 ; Builds a line to display one Subscriber

 ; Input:   ICTR                          - Selection Number

 ;          DFN                           - DFN of the Subscriber to be displayed

 ;          Y                             - Y of the 2.312 occurrence.

 ;          ^TMP("IBCNSUR4A",$J,DFN,Y)    - Array of currently selected Subscribers

 ; Output:  LINE    - Formatted for setting into the list display

 N LINE,LINEI,XXN

 S:$D(^TMP("IBCNSUR4A",$J,DFN,Y)) ICTR=ICTR_">"         ; Mark as selected

 S LINE=$$SETSTR^VALM1(ICTR,"",1,4)                     ; Selection #

 S LINE=$$SETSTR^VALM1($E($P(SRTREC,U,1),1,15),LINE,6,20)    ; Patient Name

 S LINE=$$SETSTR^VALM1($S($P(SRTREC,U,7)=-9999:" ",1:$P(SRTREC,U,7)),LINE,22,25)            ; SSN

 S LINE=$$SETSTR^VALM1($S($P(SRTREC,U,2)=-9999:" ",1:$E($P(SRTREC,U,2),1,20)),LINE,27,46)   ; Subscriber ID (first 20 chars)

 S LINE=$$SETSTR^VALM1($S($P(SRTREC,U,3)=-9999:" ",1:$$DAT1^IBOUTL($P(SRTREC,U,3))),LINE,48,55)  ; Effective Date

 S LINE=$$SETSTR^VALM1($S($P(SRTREC,U,4)=-9999:" ",1:$$DAT1^IBOUTL($P(SRTREC,U,4))),LINE,57,64)  ; Expiration Date

 S LINE=$$SETSTR^VALM1($P(SRTREC,U,5),LINE,66,68)            ; Whose

 S LINE=$$SETSTR^VALM1($S($P(SRTREC,U,6)=-9999:" ",1:$E($P(SRTREC,U,6),1,30)),LINE,71,100)            ; Patient ID

 Q LINE

 ;

HELP ;EP

 ; Help code

 ; Input: None

 D FULL^VALM1

 S VALMBCK="R"

 W @IOF,"A '>' after the Subscriber Selection number indicates that this Subscriber"

 W !,"has already been selected."

 Q

 ;

EXIT ;EP

 ; Exit code

 ; Input: None

 K IBSORT,^TMP("IBCNSUR4",$J),^TMP("IBCNSUR4IX",$J)

 D CLEAR^VALM1

 Q

 ;

SEL ;EP

 ; Protocol Action to de-select an already selected Subscriber

 ; Input:   NUMSEL                    - Current number of selected Subscribers

 ;          ^TMP("IBCNSUR4",$J)       - Current Array of displayed Subscribers

 ;          ^TMP("IBCNSUR4IX",$J)     - Current Index of displayed Subscribers

 ;          ^TMP("IBCNSUR4A,$J,DFN,Y) - Current Array of selected Subscribers

 ;

 ; Output:  NUMSEL                    - Updated number of selected Subscribers

 ;          ^TMP("IBCNSUR4A,$J,DFN,Y) - Updated Array of selected Subscribers

 ;          Selected Subscriber is removed from the worklist 

 ;          Error message displayed (potentially)

 N DFN,DFNS,DFNY,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,ERROR,IX,LINE,PROMPT,Y

 S VALMBCK="R",ERROR=0

 ; 

 ; First select the Subscriber(s) to be selected

 S PROMPT="Select Subscriber(s)"

 S DFNS=$$SELSUB(1,PROMPT,.DLINE,1,"IBCNSUR4IX")

 I DFNS="" S VALMBCK="R" Q                 ; None Selected

 F IX=1:1:$L(DFNS,",") D

 . S DFNY=$P(DFNS,",",IX)

 . S DFN=$P(DFNY,"~",1)

 . S Y=$P(DFNY,"~",2)

 . S LINE=$P(DLINE,",",IX)

 . ;

 . ; If currently selected, display an error message

 . I $D(^TMP("IBCNSUR4A",$J,DFN,Y)) D  Q

 . . W !,*7,">>>> # ",LINE," is currently selected."

 . . S ERROR=1

 . D MARK(1,DFNY,LINE,.NUMSEL)              ; Show the selection mark

 D HDR                                      ; Update the header

 D:ERROR PAUSE^VALM1

 Q

 ;

UNSEL(SELECTED) ;EP

 ; Protocol Action to de-select an already selected Subscriber

 ; Input:

 ; Optional, defaults to 0

 ;   NUMSEL                    - Current number of selected Subscribers

 ;   ^TMP("IBCNSUR4",$J)       - Current Array of displayed Subscribers

 ;   ^TMP("IBCNSUR4S",$J)      - Current Array of selected Insurance Companies

 ;   ^TMP("IBCNSUR4IX",$J)     - Current Index of displayed Subscribers

 ;   ^TMP("IBCNSUR4A,$J,DFN,Y) - Current Array of selected Subscribers

 ;

 ; Output:  NUMSEL             - Current number of selected Subscribers

 ;   ^TMP("IBCNSUR4A,$J,DFN,Y) - Updated Array of selected Subscribers

 ;

 ; Selected Subscriber is removed from the worklist 

 ; Error message displayed (potentially)

 N DFN,DFNS,DFNY,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,ERROR,IX,LINE,MSG,PROMPT,WARRAY,Y

 I '$D(SELECTED) D

 . S SELECTED=0,WARRAY="IBCNSUR4IX"

 E  S WARRAY="IBCNSUR4SIX"

 S VALMBCK="R",ERROR=0

 ;

 ; First select the Subscriber(s) to be de-selected

 S PROMPT="De-Select Subscriber(s)"

 S MSG="Are you sure you want to De-Select "

 S DFNS=$$SELSUB(1,PROMPT,.DLINE,1,WARRAY)

 I DFNS="" S VALMBCK="R" Q                 ; None Selected

 F IX=1:1:$L(DFNS,",") D

 . S DFNY=$P(DFNS,",",IX)

 . S DFN=$P(DFNY,"~",1)

 . S Y=$P(DFNY,"~",2)

 . S LINE=$P(DLINE,",",IX)

 . ;

 . ; If not currently selected, display an error message

 . I '$D(^TMP("IBCNSUR4A",$J,DFN,Y)) D  Q

 . . W !,*7,">>>> # ",LINE," is not currently selected. It cannot be de-selected."

 . . S ERROR=1

 . D MARK(0,DFNY,LINE,.NUMSEL)              ; De-Select the entry

 D HDR                                     ; Update the header

 D:ERROR PAUSE^VALM1

 Q

 ;

MARK(WHICH,DFNY,LINE,NUMSEL)   ; Mark/Remove 'Selection' from a selected

 ; Subscriber line

 ; Input:   WHICH   - 0 - Remove 'Selection' mark

 ;                    1 - Set 'Selection' mark

 ;          DFNY    - DFN and Y of the entry to Mark/Remove 'In-Progress'

 ;          LINE    - Line number being marked/unmarked

 ;          WLIST   - Worklist, the user is selecting from.

 ;          NUMSEL  - Current # of selected Subscriber

 ;          ^TMP("IBCNSUR4A",$J)- Current array of selected Subscriber 

 ; Output:  Subscriber is marked or unmarked as selected

 ;          NUMSEL  - Current # of selected Subscribers

 ;          ^TMP("IBCNSUR4A",$J)- Updated array of selected Subscribers 

 ;

 N TEXT,DFN,Y

 S DFN=$P(DFNY,"~",1)

 S Y=$P(DFNY,"~",2)

 I WHICH D                                  ; Mark as selected

 . S ^TMP("IBCNSUR4A",$J,DFN,Y)=""

 . S TEXT=LINE_">",NUMSEL=NUMSEL+1

 E  D                                       ; Mark as unselected

 . K ^TMP("IBCNSUR4A",$J,DFN,Y)

 . S TEXT=LINE,NUMSEL=NUMSEL-1

 D FLDTEXT^VALM10(LINE,"CTR",TEXT)          ; Update display

 D WRITE^VALM10(LINE)                       ; Redisplay line

 Q

 ;

SHOWSEL ;EP

 ; Protocol action used to display a listman template of the currently

 ; selected Subscribers

 ; Input:   NUMSEL                        - Current number of selected Subscribers

 ;          ^TMP("IBCNSUR4A",$J,DFN,Y)    - Current Array of selected Subscribers

 ; Output:  NUMSEL                        - Updated number of selected Subscribers

 ;          ^TMP("IBCNSUR4A",$J,DFN,Y)    - Updated Array of selected Subscribers

 S VALMBCK="R"

 D EN^VALM("IBCN SUBSCRIBER SELECTED")

 D HDR,BLD

 Q

 ;

SELSUB(FULL,PROMPT,DLINE,MULT,WLIST)    ;EP

 ; Select Subscriber(s) to perform an action upon

 ; Input:   FULL                    - 1 - full screen mode, 0 otherwise

 ;          PROMPT                  - Prompt to be displayed to the user

 ;          MULT                    - 1 to allow multiple entry selection

 ;                                    0 to only allow single entry selection

 ;                                    Optional, defaults to 0

 ;          WLIST                   - Worklist, the user is selecting from

 ;          ^TMP("IBCNSUR4IX",$J)   - Index of displayed lines of the Subscriber

 ;                                    Selector Template. 

 ;                                    Only used when WLIST="IBCNSUR4IX"

 ;          ^TMP("IBCNSUR4SIX",$J)  - Index of displayed lines of the Subscriber

 ;                                    Selected Template

 ;                                    Only used if WLIST is "IBCNSUR4IX"

 ; Output:  DLINE                   - Comma delimited list of Line #(s) of the 

 ;                                    selected Subscriber

 ; Returns: IEN(s) - Comma delimited string or IENS for the selected Subscriber(s)

 ;          Error message and "" DFNS if multi-selection and not allowed

 N DFNY,DFNS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,VALMY,X,Y

 S:'$D(MULT) MULT=0

 S:'$D(WLIST) WLIST="IBCNSUR4"

 D:FULL FULL^VALM1

 S DLINE=$P($P($G(XQORNOD(0)),"^",4),"=",2)     ; User selection with action

 S DLINE=$TR(DLINE,"/\; .",",,,,,")             ; Check for multi-selection

 S DFNS=""

 I 'MULT,DLINE["," D  Q ""                      ; Invalid multi-selection

 . W !,*7,">>>> Only single entry selection is allowed"

 . S DLINE=""

 . K DIR

 . D PAUSE^VALM1

 ;

 ; Let the user enter their selection(s)

 D EN^VALM2($G(XQORNOD(0)),"O")                 ; ListMan generic selector

 I '$D(VALMY) Q ""

 S IX="",DLINE=""

 F  D  Q:IX=""

 . S IX=$O(VALMY(IX))

 . Q:IX=""

 . S DLINE=$S(DLINE="":IX,1:DLINE_","_IX)

 . S DFNY=$G(^TMP(WLIST,$J,IX))

 . S DFNS=$S(DFNS="":DFNY,1:DFNS_","_DFNY)

 Q DFNS

 ;

INIT2 ;EP for Show Selections

 ; Initialize variables and list array

 ; Input: None

 ; Output:  ^TMP("IBCNSUR4",$J) - Body lines to display

 K ^TMP("IBCNSUR4S",$J),^TMP("IBCNSUR4SIX",$J)

 D BLD2

 Q

 ;

BLD2 ; Build listman body for Show Selections

 ; Input:   None

 ; Output:  VALMCNT   - Total number of lines displayed in the body

 ;          ^TMP("IBCNSUR4S",$J)   - Body lines to display

 ;          ^TMP("IBCNSUR4SIX",$J) - Index of Entry DFNs by display line

 N DFN,DFNY,ICTR,LINE,SORTED,SRTKEY1,SRTKEY2,SRTKEY3,Y

 ;

 ; First sort the currently selected Subscribers into name order

 S DFN=""

 F  S DFN=$O(^TMP("IBCNSUR4A",$J,DFN)) Q:DFN=""  D

 . S Y=""

 . F  S Y=$O(^TMP("IBCNSUR4A",$J,DFN,Y)) Q:Y=""  D

 . . S DFNY=DFN_"~"_Y

 . . D GTSREC(DFNY,.SRTREC)

 . . S SRTKEY1=$P(SRTREC,U,IBSORT)

 . . S SRTKEY2=$P(SRTREC,U,1)   ; PATNAM

 . . S SRTKEY3=$O(SORTED(SRTKEY1,SRTKEY2,""),-1)+1

 . . S SORTED(SRTKEY1,SRTKEY2,SRTKEY3)=SRTREC

 ;

 ; Now build the lines to be displayed

 S (ICTR,VALMCNT)=0,SRTKEY1=""

 F  S SRTKEY1=$O(SORTED(SRTKEY1)) Q:SRTKEY1=""  D

 . S SRTKEY2=""

 . F  S SRTKEY2=$O(SORTED(SRTKEY1,SRTKEY2)) Q:SRTKEY2=""  D

 . . S SRTKEY3=""

 . . F  S SRTKEY3=$O(SORTED(SRTKEY1,SRTKEY2,SRTKEY3)) Q:SRTKEY3=""  D

 . . . S SRTREC=SORTED(SRTKEY1,SRTKEY2,SRTKEY3)

 . . . S DFNY=$P(SRTREC,U,8)

 . . . S DFN=$P(DFNY,"~",1),Y=$P(DFNY,"~",2)

 . . . S ICTR=ICTR+1

 . . . S LINE=$$BLDLN(ICTR,DFN,Y,SRTREC)

 . . . S VALMCNT=VALMCNT+1

 . . . D SET^VALM10(VALMCNT,LINE,LINE)

 . . . S ^TMP("IBCNSUR4SIX",$J,ICTR)=DFN_"~"_Y

 ;

 I VALMCNT=0 D

 . S ^TMP("IBCNSUR4",$J,1,0)="No Selected Subscribers were found."

 Q

 ;

EXIT2 ;EP for Show Selections

 ; Exit code

 ; Input: None

 K ^TMP("IBCNSUR4S",$J),^TMP("IBCNSUR4SIX",$J)

 D CLEAR^VALM1

 Q

 ;

SELSORT ;  select the way to sort the list screen

 N DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT,ST,STDES

 ;

 D FULL^VALM1 W !

 W !,"Select the item to sort the subscriber records on the subscriber list screen."

 S DIR(0)="SO^1:Patient Name;2:Subscriber ID;3:Effective Date;4:Date Expired;5:Whose;6:Patient ID"

 S DIR("A")="Sort the list by",DIR("B")=$P($G(IBSORT),"^",2)

 D ^DIR K DIR

 I 'Y G SELSORTX

 S IBSORT=Y_"^"_Y(0)

 ;

 ; rebuild and resort the list and update the list header

 D BLD,HDR

 ;

SELSORTX ;

 S VALMBCK="R",VALMBG=1

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCNSUR4   19425     printed  Mar 13, 2025@21:23:06                                                                                                                                                                                                   Page 2

IBCNSUR4  ;ALB/VD - SELECT MULTIPLE SUBSCRIBERS LOOK-UP UTILITY ; 14-APR-15

 +1       ;;2.0;INTEGRATED BILLING;**549**;14-APR-15;Build 54

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;;

 +4       ;

EN(IBC1,IBP1,IBDD,IBSBID,IBVAL,IBSUBACT,IBEFDT,IBEFDT1,IBEFDT2) ; Entry Point

 +1       ; Look-up Utility to Select Multiple Subscribers

 +2       ;  Input:  IBC1    --  Pointer to the company in file #36

 +3       ;          IBP1    --  Pointer to the plan in file #355.3

 +4       ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 +5       ;                      Deceased, 0 - Ignore Deceased)

 +6       ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 +7       ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 +8       ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 +9       ;          IBSUBACT --  Subscriber Filter for Active Indicator (0 - Ignore

 +10      ;                      Active Status, 1 - Filter Active, 2 - Filter Inactive)

 +11      ;                      to be excluded from selection

 +12      ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 +13      ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 +14      ;          IBEFDT1 --  Effective Date Filter Start Date.

 +15      ;          IBEFDT2 --  Effective Date Filter End Date.

 +16      ;

 +17      ; Output:  IBCNT  --  Number of Subscriber Policies to Move.

 +18      ;          ^TMP("IBCNSUR4A,$J) - Array of selected Subscribers.

 +19       DO EN^VALM("IBCN SUBSCRIBER SELECTOR")

 +20       IF +$GET(IBFASTXT)

               SET IBQUIT=1

 +21       QUIT +$GET(NUMSEL)_U_+$GET(IBSUB)

 +22      ;

HDR(SELECTED) ;EP

 +1       ; Header code for the Subscriber Selection template

 +2       ;  Input:  SELECTED -- 1=Showing header for selected listman

 +3       ;                      0=Is the default or optional value

 +4       ;

 +5       ;          IBC1    --  Pointer to the company in file #36

 +6       ;          IBP1    --  Pointer to the plan in file #355.3

 +7       ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 +8       ;                      Deceased, 0 - Ignore Deceased)

 +9       ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 +10      ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 +11      ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 +12      ;          IBSUBACT -- Subscriber Filter for Active Indicator (0 - Ignore

 +13      ;                      Active Status, 1 - Filter Active, 2 - Filter Inactive)

 +14      ;                      to be excluded from selection

 +15      ;          IBACTV  --  List of Active or Inactive policies.

 +16      ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 +17      ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 +18      ;          IBEFDT1 --  Effective Date Filter Start Date.

 +19      ;          IBEFDT2 --  Effective Date Filter End Date.

 +20      ;

 +21      ; Output:  VALMHDR --  Header information to display

 +22       NEW HCTR

 +23       if $GET(IBSORT)=""

               SET IBSORT="1^Patient Name"

 +24       SET VALMHDR(1)="Subscribers in: "_$$GET1^DIQ(36,+IBC1,.01)

           SET $EXTRACT(VALMHDR(1),50,79)="Grp Name: "_$$GET1^DIQ(355.3,+IBP1,.03)

 +25      ; Address and City

           SET VALMHDR(2)=$EXTRACT($$GET1^DIQ(36,+IBC1,.111),1,20)_"  "_$EXTRACT($$GET1^DIQ(36,+IBC1,.114),1,20)

 +26      ; ST Zip.

           SET VALMHDR(2)=VALMHDR(2)_", "_$PIECE($GET(^DIC(5,+$$GET1^DIQ(36,+IBC1,.115,"I"),0)),U,2)_" "_$EXTRACT($$GET1^DIQ(36,+IBC1,.116),1,5)

 +27       SET $EXTRACT(VALMHDR(2),53,99)="Grp #: "_$$GET1^DIQ(355.3,+IBP1,.04)

 +28      ;

 +29       SET VALMHDR(3)=+$GET(NUMSEL)_" Subscriber"_$SELECT(+$GET(NUMSEL)=1:"",1:"s")_" selected out of "_+$GET(IBSUB)

           SET $EXTRACT(VALMHDR(3),50,99)="Sorted by: "_$PIECE(IBSORT,U,2)

 +30       SET HCTR=4

 +31       SET VALMHDR(HCTR)="Filters: "_$SELECT(IBDD=1:"Living PATs",1:"All PATs")

 +32       IF $LENGTH(IBVAL)

               SET VALMHDR(HCTR)=VALMHDR(HCTR)_", SubIDs w/'"_IBVAL_"'"

 +33       IF $LENGTH(VALMHDR(HCTR))>57

               SET HCTR=HCTR+1

 +34       IF '$DATA(VALMHDR(HCTR))

               SET VALMHDR(HCTR)="        "

 +35       SET VALMHDR(HCTR)=VALMHDR(HCTR)_$SELECT(IBSUBACT=1:", Active",IBSUBACT=2:", Inactive",IBSUBACT=3:", All",1:$SELECT(+IBSUBACT:"",1:", All"))_" Policies"

 +36       IF $LENGTH(VALMHDR(HCTR))>46

               SET HCTR=HCTR+1

 +37       IF +IBEFDT

               Begin DoDot:1

 +38               IF '$DATA(VALMHDR(HCTR))

                       SET VALMHDR(HCTR)="        "

 +39               SET VALMHDR(HCTR)=VALMHDR(HCTR)_", Eff "_$$DAT1^IBOUTL(IBEFDT1)_"-"_$$DAT1^IBOUTL(IBEFDT2)

               End DoDot:1

 +40       QUIT 

 +41      ;

INIT      ;EP

 +1       ; Initialize variables and list array

 +2       ; Input: None

 +3       ; Output:  ^TMP("IBCNSUR4",$J) - Body lines to display

 +4        KILL ^TMP("IBCNSUR4",$JOB),^TMP("IBCNSUR4IX",$JOB),^TMP("IBCNSUR4A",$JOB)

 +5        if $GET(IBSORT)=""

               SET IBSORT="1^Patient Name"

 +6        DO BLD

 +7        QUIT 

 +8       ;

BLD       ; Build listman body

 +1       ;  Input:  IBC1    --  Pointer to the company in file #36

 +2       ;          IBP1    --  Pointer to the plan in file #355.3

 +3       ;          IBDD    --  Deceased Subscribers Indicator (1 - Include

 +4       ;                      Deceased, 0 - Ignore Deceased)

 +5       ;          IBSBID  --  Subscriber ID Filter (1 - Use IBVAL to filter

 +6       ;                      Subscriber IDs, 0 - Ignore Subscriber IDs)

 +7       ;          IBVAL   --  Use the contained value to screen Subscriber IDs.

 +8       ;          IBSUBACT -- Subscriber Filter for Active Indicator (0 - Include

 +9       ;                      Both Active & Inactive, 1 - Include Active,

 +10      ;                      2 - Include Inactive) to be included in selection.

 +11      ;          IBACTV  --  List of Active or Inactive policies.

 +12      ;          IBEFDT  --  Effective Date Filter Indicator (1 - Use Effective

 +13      ;                      Dates as a filter, 0 - Ignore Effective Dates.)

 +14      ;          IBEFDT1 --  Effective Date Filter Start Date.

 +15      ;          IBEFDT2 --  Effective Date Filter End Date.

 +16      ; Output:  VALMCNT   - Total number of lines displayed in the body

 +17      ;          ^TMP("IBCNSUR4",$J)   - Body lines to display

 +18      ;          ^TMP("IBCNSUR4IX",$J) - Index of Entry IENs by display line

 +19      ;

 +20       NEW ACTIVE,CURCNT,DFN,DFNY,OMIT,PATEFF,PATEXP,PATID,PATNAM,PATSID,PATSSN,PATWHO

 +21       NEW SORTED,SRTKEY1,SRTKEY2,SRTKEY3,SRTREC,Y

 +22       SET IBSUB=$$SUBS^IBCNSJ(IBC1,IBP1,0,"^TMP($J,""IBCNSURS"")")

 +23       SET (CURCNT,VALMCNT)=0

 +24       IF '+IBSUB

               SET ^TMP("IBCNSUR4",$JOB,1,0)="*  This group plan has no subscribers!"

               QUIT 

 +25       IF IBSUB

               Begin DoDot:1

 +26               SET DFN=""

 +27               FOR 

                       SET DFN=$ORDER(^TMP($JOB,"IBCNSURS",DFN))

                       if DFN=""

                           QUIT 

                       Begin DoDot:2

 +28                       SET Y=""

 +29                       FOR 

                               SET Y=$ORDER(^TMP($JOB,"IBCNSURS",DFN,Y))

                               if Y=""

                                   QUIT 

                               Begin DoDot:3

 +30                               SET OMIT=0

                                   SET DFNY=DFN_"~"_Y

 +31                               DO GTSREC(DFNY,.SRTREC)

 +32                               SET PATSID=$PIECE(SRTREC,U,2)

                                   SET PATEFF=$PIECE(SRTREC,U,3)

                                   SET PATEXP=$PIECE(SRTREC,U,4)

 +33                               SET ACTIVE=$SELECT('PATEXP:1,DT>+PATEXP:0,1:1)

 +34      ; If ignoring deceased and subscriber is deceased exclude.

                                   IF +IBDEAD

                                       IF +$$GET1^DIQ(2,DFN_",",.351,"I")

                                           QUIT 

 +35      ; Sub ID doesn't contain the Sub ID screen exclude.

                                   IF +IBSUBID

                                       IF $LENGTH(IBVALUE)

                                           IF ($$UP^XLFSTR(PATSID)'[IBVALUE)

                                               QUIT 

 +36      ; Active vs Inactive

                                   IF +IBSUBACT

                                       Begin DoDot:4

 +37      ; Include active Policies.

                                           IF IBSUBACT=1

                                               IF 'ACTIVE

                                                   SET OMIT=1

                                                   QUIT 

 +38      ; Include inactive Policies.

                                           IF IBSUBACT=2

                                               IF +ACTIVE

                                                   SET OMIT=1

                                       End DoDot:4

                                       if OMIT

                                           QUIT 

 +39      ; Effective Date

                                   IF +IBEFDT

                                       Begin DoDot:4

 +40      ; Effective date is less than starting date.

                                           IF PATEFF<IBEFDT1

                                               SET OMIT=1

                                               QUIT 

 +41      ; Effective date is less than ending date.

                                           IF PATEFF>IBEFDT2

                                               SET OMIT=1

                                       End DoDot:4

                                       if OMIT

                                           QUIT 

 +42                               IF '$DATA(IBSORT)

                                       SET IBSORT=1

 +43                               SET SRTKEY1=$PIECE(SRTREC,U,IBSORT)

 +44      ; PATNAM

                                   SET SRTKEY2=$PIECE(SRTREC,U,1)

 +45                               SET SRTKEY3=$ORDER(SORTED(SRTKEY1,SRTKEY2,""),-1)+1

 +46                               SET SORTED(SRTKEY1,SRTKEY2,SRTKEY3)=SRTREC

 +47      ;

                               End DoDot:3

                       End DoDot:2

 +48               SET SRTKEY1=""

 +49               FOR 

                       SET SRTKEY1=$ORDER(SORTED(SRTKEY1))

                       if SRTKEY1=""

                           QUIT 

                       Begin DoDot:2

 +50                       SET SRTKEY2=""

 +51                       FOR 

                               SET SRTKEY2=$ORDER(SORTED(SRTKEY1,SRTKEY2))

                               if SRTKEY2=""

                                   QUIT 

                               Begin DoDot:3

 +52                               SET SRTKEY3=""

 +53                               FOR 

                                       SET SRTKEY3=$ORDER(SORTED(SRTKEY1,SRTKEY2,SRTKEY3))

                                       if SRTKEY3=""

                                           QUIT 

                                       Begin DoDot:4

 +54                                       SET SRTREC=SORTED(SRTKEY1,SRTKEY2,SRTKEY3)

 +55                                       SET DFNY=$PIECE(SRTREC,U,8)

                                           SET DFN=$PIECE(DFNY,"~",1)

                                           SET Y=$PIECE(DFNY,"~",2)

 +56                                       SET CURCNT=CURCNT+1

 +57                                       SET LINE=$$BLDLN(CURCNT,DFN,Y,SRTREC)

 +58                                       SET VALMCNT=VALMCNT+1

 +59                                       DO SET^VALM10(VALMCNT,LINE,LINE)

 +60                                       SET ^TMP("IBCNSUR4IX",$JOB,CURCNT)=DFNY

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +61       IF IBSUB

               SET IBSUB=CURCNT

 +62       IF VALMCNT=0

               Begin DoDot:1

 +63               SET ^TMP("IBCNSUR4",$JOB,1,0)="No Subscribers with Selection Criteria were found."

               End DoDot:1

 +64       QUIT 

 +65      ;

GTSREC(DFNY,SRTREC) ; Get the sort record data

 +1        NEW DFN,PATEFF,PATEXP,PATID,PATNAM,PATSID,PATSSN,PATWHO,Y

 +2        SET SRTREC=""

 +3        SET DFN=$PIECE(DFNY,"~",1)

           SET Y=$PIECE(DFNY,"~",2)

 +4        SET PATNAM=$$GET1^DIQ(2,DFN_",",.01)

           SET PATNAM=$SELECT($LENGTH(PATNAM):PATNAM,1:" ")

 +5        SET PATSSN=$EXTRACT($$GET1^DIQ(2,DFN_",",.09),6,9)

           SET PATSSN=$SELECT($LENGTH(PATSSN):PATSSN,1:" ")

 +6       ;Only use the 1st 20 chars of SUBID.

           SET PATSID=$EXTRACT($$GET1^DIQ(2.312,Y_","_DFN_",",7.02),1,20)

           SET PATSID=$SELECT($LENGTH(PATSID):PATSID,1:" ")

 +7        SET PATEFF=$$GET1^DIQ(2.312,Y_","_DFN_",",8,"I")

           SET PATEFF=$SELECT($LENGTH(PATEFF):PATEFF,1:" ")

 +8        SET PATEXP=$$GET1^DIQ(2.312,Y_","_DFN_",",3,"I")

           SET PATEXP=$SELECT($LENGTH(PATEXP):PATEXP,1:" ")

 +9        SET PATWHO=$$GET1^DIQ(2.312,Y_","_DFN_",",6)

           SET PATWHO=$SELECT('$LENGTH(PATWHO):"UNK",1:$EXTRACT(PATWHO,1,3))

 +10       SET PATID=$$GET1^DIQ(2.312,Y_","_DFN_",",5.01)

           SET PATID=$SELECT($LENGTH(PATID):PATID,1:" ")

 +11       SET SRTREC=PATNAM_U_PATSID_U_PATEFF_U_PATEXP_U_PATWHO_U_PATID_U_PATSSN_U_DFNY

 +12       QUIT 

 +13      ;

BLDLN(ICTR,DFN,Y,SRTREC) ;EP

 +1       ; Also called from BLD^IBCNEILK2

 +2       ; Builds a line to display one Subscriber