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 ---[H[J[2J[HIBCNSUR4 19425 printed Sep 23, 2025@19:54:22 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
+3 ; Input: ICTR - Selection Number
+4 ; DFN - DFN of the Subscriber to be displayed
+5 ; Y - Y of the 2.312 occurrence.
+6 ; ^TMP("IBCNSUR4A",$J,DFN,Y) - Array of currently selected Subscribers
+7 ; Output: LINE - Formatted for setting into the list display
+8 NEW LINE,LINEI,XXN
+9 ; Mark as selected
if $DATA(^TMP("IBCNSUR4A",$JOB,DFN,Y))
SET ICTR=ICTR_">"
+10 ; Selection #
SET LINE=$$SETSTR^VALM1(ICTR,"",1,4)
+11 ; Patient Name
SET LINE=$$SETSTR^VALM1($EXTRACT($PIECE(SRTREC,U,1),1,15),LINE,6,20)
+12 ; SSN
SET LINE=$$SETSTR^VALM1($SELECT($PIECE(SRTREC,U,7)=-9999:" ",1:$PIECE(SRTREC,U,7)),LINE,22,25)
+13 ; Subscriber ID (first 20 chars)
SET LINE=$$SETSTR^VALM1($SELECT($PIECE(SRTREC,U,2)=-9999:" ",1:$EXTRACT($PIECE(SRTREC,U,2),1,20)),LINE,27,46)
+14 ; Effective Date
SET LINE=$$SETSTR^VALM1($SELECT($PIECE(SRTREC,U,3)=-9999:" ",1:$$DAT1^IBOUTL($PIECE(SRTREC,U,3))),LINE,48,55)
+15 ; Expiration Date
SET LINE=$$SETSTR^VALM1($SELECT($PIECE(SRTREC,U,4)=-9999:" ",1:$$DAT1^IBOUTL($PIECE(SRTREC,U,4))),LINE,57,64)
+16 ; Whose
SET LINE=$$SETSTR^VALM1($PIECE(SRTREC,U,5),LINE,66,68)
+17 ; Patient ID
SET LINE=$$SETSTR^VALM1($SELECT($PIECE(SRTREC,U,6)=-9999:" ",1:$EXTRACT($PIECE(SRTREC,U,6),1,30)),LINE,71,100)
+18 QUIT LINE
+19 ;
HELP ;EP
+1 ; Help code
+2 ; Input: None
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 WRITE @IOF,"A '>' after the Subscriber Selection number indicates that this Subscriber"
+6 WRITE !,"has already been selected."
+7 QUIT
+8 ;
EXIT ;EP
+1 ; Exit code
+2 ; Input: None
+3 KILL IBSORT,^TMP("IBCNSUR4",$JOB),^TMP("IBCNSUR4IX",$JOB)
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
SEL ;EP
+1 ; Protocol Action to de-select an already selected Subscriber
+2 ; Input: NUMSEL - Current number of selected Subscribers
+3 ; ^TMP("IBCNSUR4",$J) - Current Array of displayed Subscribers
+4 ; ^TMP("IBCNSUR4IX",$J) - Current Index of displayed Subscribers
+5 ; ^TMP("IBCNSUR4A,$J,DFN,Y) - Current Array of selected Subscribers
+6 ;
+7 ; Output: NUMSEL - Updated number of selected Subscribers
+8 ; ^TMP("IBCNSUR4A,$J,DFN,Y) - Updated Array of selected Subscribers
+9 ; Selected Subscriber is removed from the worklist
+10 ; Error message displayed (potentially)
+11 NEW DFN,DFNS,DFNY,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,ERROR,IX,LINE,PROMPT,Y
+12 SET VALMBCK="R"
SET ERROR=0
+13 ;
+14 ; First select the Subscriber(s) to be selected
+15 SET PROMPT="Select Subscriber(s)"
+16 SET DFNS=$$SELSUB(1,PROMPT,.DLINE,1,"IBCNSUR4IX")
+17 ; None Selected
IF DFNS=""
SET VALMBCK="R"
QUIT
+18 FOR IX=1:1:$LENGTH(DFNS,",")
Begin DoDot:1
+19 SET DFNY=$PIECE(DFNS,",",IX)
+20 SET DFN=$PIECE(DFNY,"~",1)
+21 SET Y=$PIECE(DFNY,"~",2)
+22 SET LINE=$PIECE(DLINE,",",IX)
+23 ;
+24 ; If currently selected, display an error message
+25 IF $DATA(^TMP("IBCNSUR4A",$JOB,DFN,Y))
Begin DoDot:2
+26 WRITE !,*7,">>>> # ",LINE," is currently selected."
+27 SET ERROR=1
End DoDot:2
QUIT
+28 ; Show the selection mark
DO MARK(1,DFNY,LINE,.NUMSEL)
End DoDot:1
+29 ; Update the header
DO HDR
+30 if ERROR
DO PAUSE^VALM1
+31 QUIT
+32 ;
UNSEL(SELECTED) ;EP
+1 ; Protocol Action to de-select an already selected Subscriber
+2 ; Input:
+3 ; Optional, defaults to 0
+4 ; NUMSEL - Current number of selected Subscribers
+5 ; ^TMP("IBCNSUR4",$J) - Current Array of displayed Subscribers
+6 ; ^TMP("IBCNSUR4S",$J) - Current Array of selected Insurance Companies
+7 ; ^TMP("IBCNSUR4IX",$J) - Current Index of displayed Subscribers
+8 ; ^TMP("IBCNSUR4A,$J,DFN,Y) - Current Array of selected Subscribers
+9 ;
+10 ; Output: NUMSEL - Current number of selected Subscribers
+11 ; ^TMP("IBCNSUR4A,$J,DFN,Y) - Updated Array of selected Subscribers
+12 ;
+13 ; Selected Subscriber is removed from the worklist
+14 ; Error message displayed (potentially)
+15 NEW DFN,DFNS,DFNY,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,ERROR,IX,LINE,MSG,PROMPT,WARRAY,Y
+16 IF '$DATA(SELECTED)
Begin DoDot:1
+17 SET SELECTED=0
SET WARRAY="IBCNSUR4IX"
End DoDot:1
+18 IF '$TEST
SET WARRAY="IBCNSUR4SIX"
+19 SET VALMBCK="R"
SET ERROR=0
+20 ;
+21 ; First select the Subscriber(s) to be de-selected
+22 SET PROMPT="De-Select Subscriber(s)"
+23 SET MSG="Are you sure you want to De-Select "
+24 SET DFNS=$$SELSUB(1,PROMPT,.DLINE,1,WARRAY)
+25 ; None Selected
IF DFNS=""
SET VALMBCK="R"
QUIT
+26 FOR IX=1:1:$LENGTH(DFNS,",")
Begin DoDot:1
+27 SET DFNY=$PIECE(DFNS,",",IX)
+28 SET DFN=$PIECE(DFNY,"~",1)
+29 SET Y=$PIECE(DFNY,"~",2)
+30 SET LINE=$PIECE(DLINE,",",IX)
+31 ;
+32 ; If not currently selected, display an error message
+33 IF '$DATA(^TMP("IBCNSUR4A",$JOB,DFN,Y))
Begin DoDot:2
+34 WRITE !,*7,">>>> # ",LINE," is not currently selected. It cannot be de-selected."
+35 SET ERROR=1
End DoDot:2
QUIT
+36 ; De-Select the entry
DO MARK(0,DFNY,LINE,.NUMSEL)
End DoDot:1
+37 ; Update the header
DO HDR
+38 if ERROR
DO PAUSE^VALM1
+39 QUIT
+40 ;
MARK(WHICH,DFNY,LINE,NUMSEL) ; Mark/Remove 'Selection' from a selected
+1 ; Subscriber line
+2 ; Input: WHICH - 0 - Remove 'Selection' mark
+3 ; 1 - Set 'Selection' mark
+4 ; DFNY - DFN and Y of the entry to Mark/Remove 'In-Progress'
+5 ; LINE - Line number being marked/unmarked
+6 ; WLIST - Worklist, the user is selecting from.
+7 ; NUMSEL - Current # of selected Subscriber
+8 ; ^TMP("IBCNSUR4A",$J)- Current array of selected Subscriber
+9 ; Output: Subscriber is marked or unmarked as selected
+10 ; NUMSEL - Current # of selected Subscribers
+11 ; ^TMP("IBCNSUR4A",$J)- Updated array of selected Subscribers
+12 ;
+13 NEW TEXT,DFN,Y
+14 SET DFN=$PIECE(DFNY,"~",1)
+15 SET Y=$PIECE(DFNY,"~",2)
+16 ; Mark as selected
IF WHICH
Begin DoDot:1
+17 SET ^TMP("IBCNSUR4A",$JOB,DFN,Y)=""
+18 SET TEXT=LINE_">"
SET NUMSEL=NUMSEL+1
End DoDot:1
+19 ; Mark as unselected
IF '$TEST
Begin DoDot:1
+20 KILL ^TMP("IBCNSUR4A",$JOB,DFN,Y)
+21 SET TEXT=LINE
SET NUMSEL=NUMSEL-1
End DoDot:1
+22 ; Update display
DO FLDTEXT^VALM10(LINE,"CTR",TEXT)
+23 ; Redisplay line
DO WRITE^VALM10(LINE)
+24 QUIT
+25 ;
SHOWSEL ;EP
+1 ; Protocol action used to display a listman template of the currently
+2 ; selected Subscribers
+3 ; Input: NUMSEL - Current number of selected Subscribers
+4 ; ^TMP("IBCNSUR4A",$J,DFN,Y) - Current Array of selected Subscribers
+5 ; Output: NUMSEL - Updated number of selected Subscribers
+6 ; ^TMP("IBCNSUR4A",$J,DFN,Y) - Updated Array of selected Subscribers
+7 SET VALMBCK="R"
+8 DO EN^VALM("IBCN SUBSCRIBER SELECTED")
+9 DO HDR
DO BLD
+10 QUIT
+11 ;
SELSUB(FULL,PROMPT,DLINE,MULT,WLIST) ;EP
+1 ; Select Subscriber(s) to perform an action upon
+2 ; Input: FULL - 1 - full screen mode, 0 otherwise
+3 ; PROMPT - Prompt to be displayed to the user
+4 ; MULT - 1 to allow multiple entry selection
+5 ; 0 to only allow single entry selection
+6 ; Optional, defaults to 0
+7 ; WLIST - Worklist, the user is selecting from
+8 ; ^TMP("IBCNSUR4IX",$J) - Index of displayed lines of the Subscriber
+9 ; Selector Template.
+10 ; Only used when WLIST="IBCNSUR4IX"
+11 ; ^TMP("IBCNSUR4SIX",$J) - Index of displayed lines of the Subscriber
+12 ; Selected Template
+13 ; Only used if WLIST is "IBCNSUR4IX"
+14 ; Output: DLINE - Comma delimited list of Line #(s) of the
+15 ; selected Subscriber
+16 ; Returns: IEN(s) - Comma delimited string or IENS for the selected Subscriber(s)
+17 ; Error message and "" DFNS if multi-selection and not allowed
+18 NEW DFNY,DFNS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,VALMY,X,Y
+19 if '$DATA(MULT)
SET MULT=0
+20 if '$DATA(WLIST)
SET WLIST="IBCNSUR4"
+21 if FULL
DO FULL^VALM1
+22 ; User selection with action
SET DLINE=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+23 ; Check for multi-selection
SET DLINE=$TRANSLATE(DLINE,"/\; .",",,,,,")
+24 SET DFNS=""
+25 ; Invalid multi-selection
IF 'MULT
IF DLINE[","
Begin DoDot:1
+26 WRITE !,*7,">>>> Only single entry selection is allowed"
+27 SET DLINE=""
+28 KILL DIR
+29 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+30 ;
+31 ; Let the user enter their selection(s)
+32 ; ListMan generic selector
DO EN^VALM2($GET(XQORNOD(0)),"O")
+33 IF '$DATA(VALMY)
QUIT ""
+34 SET IX=""
SET DLINE=""
+35 FOR
Begin DoDot:1
+36 SET IX=$ORDER(VALMY(IX))
+37 if IX=""
QUIT
+38 SET DLINE=$SELECT(DLINE="":IX,1:DLINE_","_IX)
+39 SET DFNY=$GET(^TMP(WLIST,$JOB,IX))
+40 SET DFNS=$SELECT(DFNS="":DFNY,1:DFNS_","_DFNY)
End DoDot:1
if IX=""
QUIT
+41 QUIT DFNS
+42 ;
INIT2 ;EP for Show Selections
+1 ; Initialize variables and list array
+2 ; Input: None
+3 ; Output: ^TMP("IBCNSUR4",$J) - Body lines to display
+4 KILL ^TMP("IBCNSUR4S",$JOB),^TMP("IBCNSUR4SIX",$JOB)
+5 DO BLD2
+6 QUIT
+7 ;
BLD2 ; Build listman body for Show Selections
+1 ; Input: None
+2 ; Output: VALMCNT - Total number of lines displayed in the body
+3 ; ^TMP("IBCNSUR4S",$J) - Body lines to display
+4 ; ^TMP("IBCNSUR4SIX",$J) - Index of Entry DFNs by display line
+5 NEW DFN,DFNY,ICTR,LINE,SORTED,SRTKEY1,SRTKEY2,SRTKEY3,Y
+6 ;
+7 ; First sort the currently selected Subscribers into name order
+8 SET DFN=""
+9 FOR
SET DFN=$ORDER(^TMP("IBCNSUR4A",$JOB,DFN))
if DFN=""
QUIT
Begin DoDot:1
+10 SET Y=""
+11 FOR
SET Y=$ORDER(^TMP("IBCNSUR4A",$JOB,DFN,Y))
if Y=""
QUIT
Begin DoDot:2
+12 SET DFNY=DFN_"~"_Y
+13 DO GTSREC(DFNY,.SRTREC)
+14 SET SRTKEY1=$PIECE(SRTREC,U,IBSORT)
+15 ; PATNAM
SET SRTKEY2=$PIECE(SRTREC,U,1)
+16 SET SRTKEY3=$ORDER(SORTED(SRTKEY1,SRTKEY2,""),-1)+1
+17 SET SORTED(SRTKEY1,SRTKEY2,SRTKEY3)=SRTREC
End DoDot:2
End DoDot:1
+18 ;
+19 ; Now build the lines to be displayed
+20 SET (ICTR,VALMCNT)=0
SET SRTKEY1=""
+21 FOR
SET SRTKEY1=$ORDER(SORTED(SRTKEY1))
if SRTKEY1=""
QUIT
Begin DoDot:1
+22 SET SRTKEY2=""
+23 FOR
SET SRTKEY2=$ORDER(SORTED(SRTKEY1,SRTKEY2))
if SRTKEY2=""
QUIT
Begin DoDot:2
+24 SET SRTKEY3=""
+25 FOR
SET SRTKEY3=$ORDER(SORTED(SRTKEY1,SRTKEY2,SRTKEY3))
if SRTKEY3=""
QUIT
Begin DoDot:3
+26 SET SRTREC=SORTED(SRTKEY1,SRTKEY2,SRTKEY3)
+27 SET DFNY=$PIECE(SRTREC,U,8)
+28 SET DFN=$PIECE(DFNY,"~",1)
SET Y=$PIECE(DFNY,"~",2)
+29 SET ICTR=ICTR+1
+30 SET LINE=$$BLDLN(ICTR,DFN,Y,SRTREC)
+31 SET VALMCNT=VALMCNT+1
+32 DO SET^VALM10(VALMCNT,LINE,LINE)
+33 SET ^TMP("IBCNSUR4SIX",$JOB,ICTR)=DFN_"~"_Y
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 IF VALMCNT=0
Begin DoDot:1
+36 SET ^TMP("IBCNSUR4",$JOB,1,0)="No Selected Subscribers were found."
End DoDot:1
+37 QUIT
+38 ;
EXIT2 ;EP for Show Selections
+1 ; Exit code
+2 ; Input: None
+3 KILL ^TMP("IBCNSUR4S",$JOB),^TMP("IBCNSUR4SIX",$JOB)
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
SELSORT ; select the way to sort the list screen
+1 NEW DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT,ST,STDES
+2 ;
+3 DO FULL^VALM1
WRITE !
+4 WRITE !,"Select the item to sort the subscriber records on the subscriber list screen."
+5 SET DIR(0)="SO^1:Patient Name;2:Subscriber ID;3:Effective Date;4:Date Expired;5:Whose;6:Patient ID"
+6 SET DIR("A")="Sort the list by"
SET DIR("B")=$PIECE($GET(IBSORT),"^",2)
+7 DO ^DIR
KILL DIR
+8 IF 'Y
GOTO SELSORTX
+9 SET IBSORT=Y_"^"_Y(0)
+10 ;
+11 ; rebuild and resort the list and update the list header
+12 DO BLD
DO HDR
+13 ;
SELSORTX ;
+1 SET VALMBCK="R"
SET VALMBG=1
+2 QUIT
+3 ;
