RCDPEP ;AITC/CJE - FLAG PAYERS AS PHARMACY/TRICARE ; 19-APR-2017
;;4.5;Accounts Receivable;**321,326,332,371**;;Build 29
;Per VA Directive 6402, this routine should not be modified.
;
EN(FILTER,DATEFILT) ; -- main entry point for RCDPE PAYER FLAGS template
; Input: FILTER - A=All payers, P=Pharmacy payers, T=Tricare payers,
; M=Medical (Neither Pharmacy nor Tricare)
; DATEFILT - Additional Filter by Date. Has 3 pieces by '^'
; Piece 1 - 1=Filter by date, 0=Don't
; Piece 2 - START - First DATE ADDED to include(FM format)
; Piece 3 - END - Last DATE ADDED to include (FM format)
;
I '$D(DATEFILT) S DATEFILT=$$GETDATE()
I DATEFILT=-1 Q ;
I '$D(FILTER) S FILTER=$$GETFILT()
I FILTER=-1 Q ;
;
D PAYEN^RCDPESP6 ; PRCA*4.5*332
D EN^VALM("RCDPE PAYER FLAGS")
D PAYEX^RCDPESP6 ; PRCA*4.5*332
Q
;
GETDATE() ; Ask if the user wants to filter by date. If so prompt for start
; and end dates.
; Input: None
; Output: Return value=date filter parameters delimiter by '^'
; Piece 1 - 1=Filter by date, 0=Don't
; Piece 2 - START - First DATE ADDED to include(FM format)
; Piece 3 - END - Last DATE ADDED to include (FM format)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,FD1,FD2,FILTER,OLDDATE,OD1,OD2,RETURN,X,XX,Y
D FULL^VALM1
S VALMBCK="R"
S RETURN="0"
;
S XX=$P($P($G(XQORNOD(0)),"^",4),"=",2) ; User selection with action
S FD1=$P(XX,";",2),FD2=$P(XX,";",3)
; See if user selection is valid (must be T + or - N days)
S FD1=$$PARSED(FD1)
S FD2=$$PARSED(FD2)
I FD1,FD2 Q 1_"^"_FD1_"^"_FD2
;
S OLDDATE=$G(DATEFILT,0)
S OD1=$P(OLDDATE,"^",2),OD2=$P(OLDDATE,"^",3)
;
S DIR(0)="YA"
S DIR("A")="Filter by Date Added? "
S DIR("B")=$S(OLDDATE:"YES",1:"NO")
S DIR("?",1)="Enter 'Y' or 'Yes' to filter the list by DATE ADDED"
S DIR("?")="Enter 'N' or 'No' if you do not wish to filter the list by date"
D ^DIR
I $D(DIRUT) Q -1
I Y=0 Q 0
S RETURN=1
;
; Prompt for start and end date
K DIR
S DIR(0)="DA^"
S DIR("A")="Filter start date: "
; set default to existing filter start date if it is set.
I OD1'="" S DIR("B")=$$FMTE^XLFDT(OD1,"2DZ")
D ^DIR
I $D(DIRUT) Q -1
S (FD1,$P(RETURN,"^",2))=Y
;
K DIR
S DIR(0)="DA^"_FD1_":"_DT
S DIR("A")="Filter end date ("
S DIR("A")=DIR("A")_$$FMTE^XLFDT(FD1,"2DZ")_"-"
S DIR("A")=DIR("A")_$$FMTE^XLFDT(DT,"2DZ")_"): "
; Set default to existing filter end date if it is valid.
; (it must follow the selected start date). Otherwise default to today.
I OD2'="",OD2'<FD1 S DIR("B")=$$FMTE^XLFDT(OD2,"2DZ")
I '$D(DIR("B")) S DIR("B")="T"
D ^DIR
I $D(DIRUT) Q -1
S (FD2,$P(RETURN,"^",3))=Y
;
Q RETURN
;
GETFILT() ; Get filter on payer type
; Input: None
; Return: Filter type.
; A=All payers, P=Pharmacy payers, T=Tricare payers,
; M=Medical (Neither Pharmacy nor Tricare)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,FILTER,X,XX,Y
; Check for value specified on protocol
S XX=$P($P($G(XQORNOD(0)),"^",4),"=",2) ; User selection with action
S XX=$E(XX)
I XX'="","APTM"[XX Q XX
;
S DIR(0)="SA^A:All;P:Pharmacy only;T:Tricare only;M:Medical"
S DIR("A")="Select payers to show. (A)ll, (P)harmacy, (T)ricare, (M)edical: "
S DIR("B")="A"
S DIR("?",1)="Select the type of filter to determine what payers will"
S DIR("?",2)="be displayed as follows:"
S DIR("?",3)=" A - All payers including those with and without a flag"
S DIR("?",4)=" P - Only payers flagged for Pharmacy"
S DIR("?",5)=" T - Only payers flagged for Tricare"
S DIR("?")=" M - Payers NOT flagged for Pharmacy or Tricare"
; S DIR("??")="RCDPE PAYER FLAGS FILTER"
;
D ^DIR
I $D(DIRUT) Q -1
Q Y
;
HDR ; EP - header code for RCDPE PAYER FLAGS template
; Input: Variables FILTER and DATEFILT are assumed to exist
; Output: ListMan template header in VALMHDR array
;
; Show active filters in the template header
N FTEXT
S FTEXT=$S(FILTER="P":"Pharmacy",FILTER="T":"Tricare",FILTER="M":"Medical",1:"All")
S FTEXT=$$UP^XLFSTR(FTEXT)
S FTEXT=FTEXT_" Payers"
I DATEFILT D ;
. S FTEXT=FTEXT_" added between "
. S FTEXT=FTEXT_$$FMTE^XLFDT($P(DATEFILT,"^",2),"2DZ")
. S FTEXT=FTEXT_" and "_$$FMTE^XLFDT($P(DATEFILT,"^",3),"2DZ")
S VALMHDR(1)="Current Filter: "_FTEXT
Q
;
INIT ; EP - init variables and list array for RCDPE PAYER FLAGS template
; Input: Variables FILTER and DATEFILT are assumed to exist
; Output: ^TMP("RCDPEP",$J) - Body lines to display for selected template
; ^TMP($J,"RCDPEPIX") - Index of displayed payers
S SORT="B"
I $G(FILTER)="" S FILTER="A"
I $G(DATEFILT)="" S DATEFILT=0
K ^TMP("RCDPEP",$J),^TMP($J,"RCDPEPIX")
D BLD(SORT,FILTER,DATEFILT)
Q ;
;
BLD(SORT,FILTER,DATEFILT) ; - Build the listman body template
; Input: SORT=Index on 344.6 to use for display order
; FILTER=Filter based on FLAG (see EN subroutine for detail)
; DATEFILT=Filter based on date added.
N CNT,LINE,LN,XX
D GETPAY(FILTER,DATEFILT) ; get the list of payers sorted and filtered.
S VALMBG=1,VALMCNT=0,LINE="",CNT=""
;
F D Q:CNT="" ;
. S CNT=$O(^TMP($J,"RCDPEPIX",CNT))
. Q:CNT="" ;
. S VALMCNT=VALMCNT+1
. D BLD1PAY(CNT)
Q
;
BLD1PAY(PAYCNT) ; (Re)build one payor line into the listman array
; Input PAYCNT - The sequence number of the payer being built
; Output - Lines set into template array (^TMP("RCDPEP",$J)).
N DATALN,LINE,XX
S LINE=$$SETSTR^VALM1(" "_PAYCNT,"",1,6) ; PRCA*4.5*371 - Add space for 2 extra characters to line number
S DATALN=^TMP($J,"RCDPEPIX",PAYCNT)
S XX=$P(DATALN,"^",2) ; Name
S XX=$E(XX,1,55) ; Truncate name to 55 characters to fit
S LINE=$$SETSTR^VALM1(XX,LINE,8,55) ; PRCA*4.5*371 - Add space for 2 extra characters to line number
S XX=$P(DATALN,"^",3) ; Payer ID
S LINE=$$SETSTR^VALM1(XX,LINE,65,10) ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number
S XX=$P(DATALN,"^",5) ; Phamacy payer flag
S LINE=$$SETSTR^VALM1(XX,LINE,76,2) ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number
S XX=$P(DATALN,"^",6) ; Tricare payer flag
S LINE=$$SETSTR^VALM1(XX,LINE,79,2)
S XX=$P(DATALN,"^",4) ; Date added
S LINE=$$SETSTR^VALM1(XX,LINE,82,10)
D SET^VALM10(PAYCNT,LINE,PAYCNT)
S XX=$P(DATALN,"^",7) ; EFT only payer
S LINE=$$SETSTR^VALM1(XX,LINE,93,3)
D SET^VALM10(PAYCNT,LINE,PAYCNT)
Q
;
GETPAY(FILTER,DATEFILT) ; Retrieve the payors sorted and filtered
; Input: FILTER=Type of filter by Pharmacy or Tricare flag
; DATEFILT=Filter by date added
; Output: ^TMP($J,"RCDPEPIX")=PIEN^NAME^PHARMACY_FLAG^TRICARE_FLAG
N CNT,NAME,PIEN
S CNT=0,NAME=""
I $G(SORT)="" S SORT="B"
S FILTER=$G(FILTER)
F D Q:NAME="" ;
. S NAME=$O(^RCY(344.6,SORT,NAME))
. Q:NAME=""
. S PIEN=""
. F S PIEN=$O(^RCY(344.6,SORT,NAME,PIEN)) Q:PIEN="" D ; PRCA*4.5*326
. . I '$$CHKPAY(PIEN,FILTER,DATEFILT) Q ;
. . S CNT=CNT+1 D GET1PAY(PIEN,CNT)
Q ;
;
GET1PAY(PIEN,CNT) ; Get the data for one payer and add it to the list
; Input: PIEN - Internal entry number to file 344.6
; CNT - Incremental counter
; Output: ^TMP($J,"RCDPEPIX",CNT)=A1^A2^A3^A4^A5^A6
; Where A1=PIEN - The payer internal entry number on file 344.6
; A2=NAME - The payer name
; A3=PAYER ID (also known as TIN)
; A4=DATE ADDED
; A5=PHARMACY PAYER - A Yes/No/Null field to flag a payer as pharmacy
; A6=TRICARE PAYER - A Yes/No/Null filed to flag a payer as tricare
;
N DATAOUT,DATEA,OUTARR,RCID,RCNAME,RCPF,RCTF
D GETS^DIQ(344.6,PIEN_",",".01;.02;.03;.09;.1","EI","OUTARR")
S RCNAME=OUTARR(344.6,PIEN_",",.01,"E")
S RCID=OUTARR(344.6,PIEN_",",.02,"E")
S DATAOUT=PIEN
S DATAOUT=DATAOUT_"^"_RCNAME ; Name
S DATAOUT=DATAOUT_"^"_RCID ; Payer ID
S DATEA=OUTARR(344.6,PIEN_",",.03,"I") ; Date added
S DATEA=$$FMTE^XLFDT(DATEA,"2DZ") ; Format as MM/DD/YY
S DATAOUT=DATAOUT_"^"_DATEA
S RCPF=$S(OUTARR(344.6,PIEN_",",.09,"I"):"Y",1:"")
S DATAOUT=DATAOUT_"^"_RCPF ; Pharmacy payer flag
S RCTF=$S(OUTARR(344.6,PIEN_",",.1,"I"):"Y",1:"")
S DATAOUT=DATAOUT_"^"_RCTF ; Tricare payer flag
S DATAOUT=DATAOUT_"^"_$S('$D(^RCY(344.4,"APT",RCNAME,RCID)):"YES",1:"") ; EFT ONLY PAYER/TIN
S ^TMP($J,"RCDPEPIX",CNT)=DATAOUT
Q
;
CHKPAY(PIEN,FILTER,DATEFILT) ; Apply selected filters to a payer
; Input: PIEN - Internal entry number to file 344.6
; FILTER - A=All payers, P=Pharmacy payers, T=Tricare payers,
; M=Medical (Neither Pharmacy nor Tricare)
; DATEFILT - Additional Filter by Date. Has 3 pieces by '^'
; Piece 1 - 1=Filter by date, 0=Don't
; Piece 2 - START - First DATE ADDED to include(FM format)
; Piece 3 - END - Last DATE ADDED to include (FM format)
; Returns: 1 if record matches filter, otherwise 0.
N D1,D2,DC,CREATED,MATCHT,MATCHD,PFLAG,TFLAG
S (MATCHT,MATCHD)=0
I FILTER="A" D ;
. S MATCHT=1
E D ;
. S PFLAG=$$GET1^DIQ(344.6,PIEN_",",.09,"I")
. S TFLAG=$$GET1^DIQ(344.6,PIEN_",",.1,"I")
. I FILTER="P",PFLAG S MATCHT=1
. I FILTER="T",TFLAG S MATCHT=1
. I FILTER="M",'PFLAG,'TFLAG S MATCHT=1
;
I 'DATEFILT D ;
. S MATCHD=1
E D ;
. S D1=$P(DATEFILT,"^",2)
. S D2=$P(DATEFILT,"^",3)
. S DC=$$GET1^DIQ(344.6,PIEN_",",.03,"I")
. S DC=$P(DC,".",1) ; strip off the time portion for comparison
. I DC=D1!(DC=D2)!(DC>D1&(DC<D2)) S MATCHD=1
;
Q MATCHT&MATCHD
;
CHKKEY() ; Check security key for editing
; Inputs: None
; Returns: 1 - User has security key editing, 0 - User does not have key
;
Q 1 ; Always return 1 since security key is no longer required.
N RET
D OWNSKEY^XUSRB(.RET,"RCDPE PAYER IDENTIFY")
I 'RET(0) D ;
. W !!,*7,">>>> Security key RCDPE PAYER IDENTIFY is required for this action"
. D PAUSE^VALM1
Q RET(0)
;
EDIT ; EP - for RCDPE PAYER FLAGS EDIT protocol
; Input: None
; Output: File 344.6 is updated
; Listman array is updated
;
N DA,DIC,DIE,DO,DR,DTOUT,EDT,LINE,PCNT,PIEN,PROMPT,RET,SEL,X,XX,Y
S VALMBCK="R"
D FULL^VALM1
; Check security key for edit access
I '$$CHKKEY() Q ;
;
S PROMPT="Select a Payer Entry to edit: "
S PIEN=$$SELENT(1,PROMPT,VALMBG,VALMLST,.SEL,"RCDPEPIX",0)
Q:'PIEN
;
; Lock Editing of this payer entry
L +^RCY(344.6,PIEN):3 I '$T D Q
. W !!,*7,"Someone else is editing this Payer Entry."
. W !,"Try again later."
. D PAUSE^VALM1
;
; Let the user edit the payer entry
S DIE="^RCY(344.6,"
W !!,"Edit flags for payer : "_$$GET1^DIQ(344.6,PIEN_",",.01,"E"),!
S DA=PIEN
S DR=".09Pharmacy Flag;.1Tricare Flag"
D ^DIE
;
L -^RCY(344.6,PIEN)
D GET1PAY(PIEN,+SEL)
D BLD1PAY(+SEL)
Q
;
SELENT(FULL,PROMPT,START,END,PCNT,WLIST,MULT) ; EP - Protocol Action
; Select Entry(s) to perform an action upon
; Called from protocols : RCDPE PAYER FLAGS EDIT
; RCDPE PAYER FLAG PHARM
; RCDPE PAYER FLAG TRIC
; Input: FULL - 1 - full screen mode, 0 otherwise
; PROMPT - Prompt to be displayed to the user
; START - Starting selection value
; END - Ending selection value
; WLIST - Worklist, the user is selecting from
; Optional, defaults to 'RCDPEPIX'
; MULT - 1 to allow multiple selection,
; 0 or null otherwise
; Optional defaults to 0
; Output: PCNT - Selected Phone Book Entry line(s)
; Returns: Selected Payer Entry IEN(s)
; Error message if invalid selection
N CTR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,PIEN,PIENS,X,XX,Y,YY
S:'$D(WLIST) WLIST="RCDPEPIX"
S:'$D(MULT) MULT=0
D:FULL FULL^VALM1
; Check for multi-selection
S PCNT=$$PARSEL($G(XQORNOD(0)),START,END)
;
; W !!!,"PCNT="_PCNT_" MULT="_MULT H 10
I 'MULT,$P(PCNT,",",2) D Q "" ; Invalid multi-selection
. W !,*7,">>>> Only single entry selection is allowed"
. K DIR
. D PAUSE^VALM1
S:PCNT="" PCNT=$$SELENTRY(PROMPT,START,END,MULT)
Q:'PCNT ""
;
S PIENS=""
F CTR=1:1:$L(PCNT,",") D
. S XX=$P(PCNT,",",CTR)
. I XX'="" D ;
. . S YY=$P(^TMP($J,WLIST,XX),"^",1)
. . S PIENS=$S(PIENS="":YY,1:PIENS_","_YY)
Q PIENS
;
SELENTRY(PROMPT,START,END,MULT) ; Select a line
; Input: PROMPT - Prompt to be displayed to the user
; START - Start comment # that can be selected
; END - Ending comment # that can be selected
; MULT - 1=Multiple selection allowed, 0=otherwise
; Returns: Selected Comment # or "" if not selected
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S MULT=+$G(MULT)
S DIR(0)=$S(MULT:"L",1:"N")_"O^"_START_":"_END_":0"
S DIR("A")=PROMPT
D ^DIR K DIR
Q Y
;
FLAGP ; EP - for RCDPE PAYER FLAG PHARM protocol
; Toggle pharmacy flag on selected lines
; Input: None
; Output: None
D FLAG("P")
Q
;
FLAGT ; EP - for RCDPE PAYER FLAG TRIC protocol
; Toggle Tricare flag on selected lines
; Input: None
; Output: None
D FLAG("T")
Q
;
FLAG(TYPE) ; Flag a list of entries as Pharmacy or Tricare
; Input: TYPE - P=Pharmacy, T=Tricare
; Output: File 344.6 is updated
; ListMan array is updated
N CONTINUE,CTR,FIELD,PERR,PIEN,PIENS,PROMPT,SELS,STOP,XX,ZS,ZZ
S FIELD=$S(TYPE="P":.09,1:.1)
S VALMBCK="R"
; Check security key for edit access
I '$$CHKKEY() Q ;
;
S PROMPT="Select lines on which to toggle "
S PROMPT=PROMPT_$S(TYPE="P":"Pharmacy",1:"Tricare")_" Flag"
S PIENS=$$SELENT(1,PROMPT,VALMBG,VALMLST,.SELS,"RCDPEPIX",1)
Q:PIENS="" ;
S (PERR,PIEN,ZZ,ZS)=""
;
; First lock all entries to be deleted
F CTR=1:1:$L(PIENS,",") D
. S PIEN=$P(PIENS,",",CTR) I PIEN="" Q ;
. S XX=$P(SELS,",",CTR)
. ;
. ; Lock this payer exclusion for editing
. L +^RCY(344.6,PIEN):3 I '$T D Q
. . S PERR=$S(PERR="":XX,1:PERR_","_XX)
. S ZZ=$S(ZZ="":PIEN,1:ZZ_","_PIEN)
. S ZS=$S(ZS="":XX,1:ZS_","_XX)
S PIENS=ZZ ; Entry(s) that can be deleted
S SELS=ZS
;
; Did we lock at least one entry?
I PIENS="" D Q
. W !!,*7,"All entries are being edited by another user - Nothing done."
. D PAUSE^VALM1
;
; Next warn the user if we couldn't lock them all
I PERR'="" D Q:STOP
. S STOP=0
. W !!,*7,"Warning: The following entries: ",PERR," are being edited by another user"
. W !,"These entries will not be updated."
. S CONTINUE=$$ASKYN("Continue with update of other payers?")
. I 'CONTINUE D
. . S STOP=1
. . F CTR=1:1:$L(PIENS,",") D
. . . S PIEN=$P(PIENS,",",CTR)
. . . L -^RCY(344.6,PIEN)
;
; Flag selected entries
F CTR=1:1:$L(PIENS,",") D ;
. N FDA,IENS,OLDVAL,VALUE
. S PIEN=$P(PIENS,",",CTR)
. S IENS=PIEN_","
. S SEL=$P(SELS,",",CTR)
. S OLDVAL=$$GET1^DIQ(344.6,IENS,FIELD,"I")
. S VALUE=$S('OLDVAL:1,1:0)
. S FDA(344.6,IENS,FIELD)=VALUE
. L -^RCY(344.6,PIEN)
. D FILE^DIE("","FDA")
. D GET1PAY(PIEN,SEL)
. D BLD1PAY(SEL)
Q
;
FILTER ; EP - for RCDPE PAYER FLAGS FILTER protocol
; Change the filter from a protocol
; Inputs - None
; Output - Sets variables FILTER and DATEFILT
N NEWDATE,NEWFILT
S VALMBCK="R"
D FULL^VALM1
S NEWDATE=$$GETDATE()
I NEWDATE=-1 Q ;
S NEWFILT=$$GETFILT()
I NEWFILT=-1 Q ;
S DATEFILT=NEWDATE
S FILTER=NEWFILT
D HDR,INIT
Q
;
PARSEL(VALMNOD,BEG,END) ; -- split out pre-answers from user
; Inputs - VALMNOD= User input from protocol menu including pre-answers
; BEG=Begining of the valid numeric range
; END=End of the valid numeric range
; Returns - Y=Comma separated list of valid numeric entries
;
; This code is adapted from VALM2.
N I,J,L,X,Y
S Y=$TR($P($P(VALMNOD,U,4),"=",2),"/\; .",",,,,,")
; Run through the list, skip invalid selections and expand ranges
S X=Y,Y=""
F I=1:1 S J=$P(X,",",I) Q:J="" D ;
. I J'["-",J>(BEG-1),J<(END+1) S Y=Y_J_"," ; single valid selection
. I J["-",J,J<$P(J,"-",2) D ;
. . F L=+J:1:+$P(J,"-",2) D ;
. . . I L>(BEG-1),L<(END+1) S Y=Y_L_"," ; valid selection from expanded range
Q Y
;
PARSED(X) ; Take a date in external format and check if it is a valid
; DATE ADDED (.03) in file 344.6
; Input - Date in External format
; Output - Date in Fileman format or 0 if the input was invalid
D VAL^DIE(344.6,"+1,",.03,"",X,.RET)
Q RET
;
ASKYN(PROMPT,DEFAULT) ; Ask a yes/no question
; Input: PROMPT - Question to be asked
; DEFAULT - Default Answer
; 1 - YES, 0 - NO
; Optional, defaults to 0
; Returns: 1 - User answered YES, 0 othewise
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S:$G(DEFAULT)'=1 DEFAULT=0
S DIR(0)="Y",DIR("A")=PROMPT
S DIR("B")=$S(DEFAULT:"YES",1:"NO")
D ^DIR
Q Y
;
HELP ; EP - for template RCDPE PAYER FLAGS help
; Input: None
; Output: Text from a help frame displayed to the screen
N FILTER,DATEFILT,XQH
S VALMBCK="R"
S XQH="RCDPE PAYER FLAGS GENERAL"
D EN^XQH
Q
;
EXIT ; -- exit code
D FULL^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEP 16924 printed Oct 16, 2024@17:45:58 Page 2
RCDPEP ;AITC/CJE - FLAG PAYERS AS PHARMACY/TRICARE ; 19-APR-2017
+1 ;;4.5;Accounts Receivable;**321,326,332,371**;;Build 29
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN(FILTER,DATEFILT) ; -- main entry point for RCDPE PAYER FLAGS template
+1 ; Input: FILTER - A=All payers, P=Pharmacy payers, T=Tricare payers,
+2 ; M=Medical (Neither Pharmacy nor Tricare)
+3 ; DATEFILT - Additional Filter by Date. Has 3 pieces by '^'
+4 ; Piece 1 - 1=Filter by date, 0=Don't
+5 ; Piece 2 - START - First DATE ADDED to include(FM format)
+6 ; Piece 3 - END - Last DATE ADDED to include (FM format)
+7 ;
+8 IF '$DATA(DATEFILT)
SET DATEFILT=$$GETDATE()
+9 ;
IF DATEFILT=-1
QUIT
+10 IF '$DATA(FILTER)
SET FILTER=$$GETFILT()
+11 ;
IF FILTER=-1
QUIT
+12 ;
+13 ; PRCA*4.5*332
DO PAYEN^RCDPESP6
+14 DO EN^VALM("RCDPE PAYER FLAGS")
+15 ; PRCA*4.5*332
DO PAYEX^RCDPESP6
+16 QUIT
+17 ;
GETDATE() ; Ask if the user wants to filter by date. If so prompt for start
+1 ; and end dates.
+2 ; Input: None
+3 ; Output: Return value=date filter parameters delimiter by '^'
+4 ; Piece 1 - 1=Filter by date, 0=Don't
+5 ; Piece 2 - START - First DATE ADDED to include(FM format)
+6 ; Piece 3 - END - Last DATE ADDED to include (FM format)
+7 ;
+8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,FD1,FD2,FILTER,OLDDATE,OD1,OD2,RETURN,X,XX,Y
+9 DO FULL^VALM1
+10 SET VALMBCK="R"
+11 SET RETURN="0"
+12 ;
+13 ; User selection with action
SET XX=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+14 SET FD1=$PIECE(XX,";",2)
SET FD2=$PIECE(XX,";",3)
+15 ; See if user selection is valid (must be T + or - N days)
+16 SET FD1=$$PARSED(FD1)
+17 SET FD2=$$PARSED(FD2)
+18 IF FD1
IF FD2
QUIT 1_"^"_FD1_"^"_FD2
+19 ;
+20 SET OLDDATE=$GET(DATEFILT,0)
+21 SET OD1=$PIECE(OLDDATE,"^",2)
SET OD2=$PIECE(OLDDATE,"^",3)
+22 ;
+23 SET DIR(0)="YA"
+24 SET DIR("A")="Filter by Date Added? "
+25 SET DIR("B")=$SELECT(OLDDATE:"YES",1:"NO")
+26 SET DIR("?",1)="Enter 'Y' or 'Yes' to filter the list by DATE ADDED"
+27 SET DIR("?")="Enter 'N' or 'No' if you do not wish to filter the list by date"
+28 DO ^DIR
+29 IF $DATA(DIRUT)
QUIT -1
+30 IF Y=0
QUIT 0
+31 SET RETURN=1
+32 ;
+33 ; Prompt for start and end date
+34 KILL DIR
+35 SET DIR(0)="DA^"
+36 SET DIR("A")="Filter start date: "
+37 ; set default to existing filter start date if it is set.
+38 IF OD1'=""
SET DIR("B")=$$FMTE^XLFDT(OD1,"2DZ")
+39 DO ^DIR
+40 IF $DATA(DIRUT)
QUIT -1
+41 SET (FD1,$PIECE(RETURN,"^",2))=Y
+42 ;
+43 KILL DIR
+44 SET DIR(0)="DA^"_FD1_":"_DT
+45 SET DIR("A")="Filter end date ("
+46 SET DIR("A")=DIR("A")_$$FMTE^XLFDT(FD1,"2DZ")_"-"
+47 SET DIR("A")=DIR("A")_$$FMTE^XLFDT(DT,"2DZ")_"): "
+48 ; Set default to existing filter end date if it is valid.
+49 ; (it must follow the selected start date). Otherwise default to today.
+50 IF OD2'=""
IF OD2'<FD1
SET DIR("B")=$$FMTE^XLFDT(OD2,"2DZ")
+51 IF '$DATA(DIR("B"))
SET DIR("B")="T"
+52 DO ^DIR
+53 IF $DATA(DIRUT)
QUIT -1
+54 SET (FD2,$PIECE(RETURN,"^",3))=Y
+55 ;
+56 QUIT RETURN
+57 ;
GETFILT() ; Get filter on payer type
+1 ; Input: None
+2 ; Return: Filter type.
+3 ; A=All payers, P=Pharmacy payers, T=Tricare payers,
+4 ; M=Medical (Neither Pharmacy nor Tricare)
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,FILTER,X,XX,Y
+6 ; Check for value specified on protocol
+7 ; User selection with action
SET XX=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+8 SET XX=$EXTRACT(XX)
+9 IF XX'=""
IF "APTM"[XX
QUIT XX
+10 ;
+11 SET DIR(0)="SA^A:All;P:Pharmacy only;T:Tricare only;M:Medical"
+12 SET DIR("A")="Select payers to show. (A)ll, (P)harmacy, (T)ricare, (M)edical: "
+13 SET DIR("B")="A"
+14 SET DIR("?",1)="Select the type of filter to determine what payers will"
+15 SET DIR("?",2)="be displayed as follows:"
+16 SET DIR("?",3)=" A - All payers including those with and without a flag"
+17 SET DIR("?",4)=" P - Only payers flagged for Pharmacy"
+18 SET DIR("?",5)=" T - Only payers flagged for Tricare"
+19 SET DIR("?")=" M - Payers NOT flagged for Pharmacy or Tricare"
+20 ; S DIR("??")="RCDPE PAYER FLAGS FILTER"
+21 ;
+22 DO ^DIR
+23 IF $DATA(DIRUT)
QUIT -1
+24 QUIT Y
+25 ;
HDR ; EP - header code for RCDPE PAYER FLAGS template
+1 ; Input: Variables FILTER and DATEFILT are assumed to exist
+2 ; Output: ListMan template header in VALMHDR array
+3 ;
+4 ; Show active filters in the template header
+5 NEW FTEXT
+6 SET FTEXT=$SELECT(FILTER="P":"Pharmacy",FILTER="T":"Tricare",FILTER="M":"Medical",1:"All")
+7 SET FTEXT=$$UP^XLFSTR(FTEXT)
+8 SET FTEXT=FTEXT_" Payers"
+9 ;
IF DATEFILT
Begin DoDot:1
+10 SET FTEXT=FTEXT_" added between "
+11 SET FTEXT=FTEXT_$$FMTE^XLFDT($PIECE(DATEFILT,"^",2),"2DZ")
+12 SET FTEXT=FTEXT_" and "_$$FMTE^XLFDT($PIECE(DATEFILT,"^",3),"2DZ")
End DoDot:1
+13 SET VALMHDR(1)="Current Filter: "_FTEXT
+14 QUIT
+15 ;
INIT ; EP - init variables and list array for RCDPE PAYER FLAGS template
+1 ; Input: Variables FILTER and DATEFILT are assumed to exist
+2 ; Output: ^TMP("RCDPEP",$J) - Body lines to display for selected template
+3 ; ^TMP($J,"RCDPEPIX") - Index of displayed payers
+4 SET SORT="B"
+5 IF $GET(FILTER)=""
SET FILTER="A"
+6 IF $GET(DATEFILT)=""
SET DATEFILT=0
+7 KILL ^TMP("RCDPEP",$JOB),^TMP($JOB,"RCDPEPIX")
+8 DO BLD(SORT,FILTER,DATEFILT)
+9 ;
QUIT
+10 ;
BLD(SORT,FILTER,DATEFILT) ; - Build the listman body template
+1 ; Input: SORT=Index on 344.6 to use for display order
+2 ; FILTER=Filter based on FLAG (see EN subroutine for detail)
+3 ; DATEFILT=Filter based on date added.
+4 NEW CNT,LINE,LN,XX
+5 ; get the list of payers sorted and filtered.
DO GETPAY(FILTER,DATEFILT)
+6 SET VALMBG=1
SET VALMCNT=0
SET LINE=""
SET CNT=""
+7 ;
+8 ;
FOR
Begin DoDot:1
+9 SET CNT=$ORDER(^TMP($JOB,"RCDPEPIX",CNT))
+10 ;
if CNT=""
QUIT
+11 SET VALMCNT=VALMCNT+1
+12 DO BLD1PAY(CNT)
End DoDot:1
if CNT=""
QUIT
+13 QUIT
+14 ;
BLD1PAY(PAYCNT) ; (Re)build one payor line into the listman array
+1 ; Input PAYCNT - The sequence number of the payer being built
+2 ; Output - Lines set into template array (^TMP("RCDPEP",$J)).
+3 NEW DATALN,LINE,XX
+4 ; PRCA*4.5*371 - Add space for 2 extra characters to line number
SET LINE=$$SETSTR^VALM1(" "_PAYCNT,"",1,6)
+5 SET DATALN=^TMP($JOB,"RCDPEPIX",PAYCNT)
+6 ; Name
SET XX=$PIECE(DATALN,"^",2)
+7 ; Truncate name to 55 characters to fit
SET XX=$EXTRACT(XX,1,55)
+8 ; PRCA*4.5*371 - Add space for 2 extra characters to line number
SET LINE=$$SETSTR^VALM1(XX,LINE,8,55)
+9 ; Payer ID
SET XX=$PIECE(DATALN,"^",3)
+10 ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number
SET LINE=$$SETSTR^VALM1(XX,LINE,65,10)
+11 ; Phamacy payer flag
SET XX=$PIECE(DATALN,"^",5)
+12 ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number
SET LINE=$$SETSTR^VALM1(XX,LINE,76,2)
+13 ; Tricare payer flag
SET XX=$PIECE(DATALN,"^",6)
+14 SET LINE=$$SETSTR^VALM1(XX,LINE,79,2)
+15 ; Date added
SET XX=$PIECE(DATALN,"^",4)
+16 SET LINE=$$SETSTR^VALM1(XX,LINE,82,10)
+17 DO SET^VALM10(PAYCNT,LINE,PAYCNT)
+18 ; EFT only payer
SET XX=$PIECE(DATALN,"^",7)
+19 SET LINE=$$SETSTR^VALM1(XX,LINE,93,3)
+20 DO SET^VALM10(PAYCNT,LINE,PAYCNT)
+21 QUIT
+22 ;
GETPAY(FILTER,DATEFILT) ; Retrieve the payors sorted and filtered
+1 ; Input: FILTER=Type of filter by Pharmacy or Tricare flag
+2 ; DATEFILT=Filter by date added
+3 ; Output: ^TMP($J,"RCDPEPIX")=PIEN^NAME^PHARMACY_FLAG^TRICARE_FLAG
+4 NEW CNT,NAME,PIEN
+5 SET CNT=0
SET NAME=""
+6 IF $GET(SORT)=""
SET SORT="B"
+7 SET FILTER=$GET(FILTER)
+8 ;
FOR
Begin DoDot:1
+9 SET NAME=$ORDER(^RCY(344.6,SORT,NAME))
+10 if NAME=""
QUIT
+11 SET PIEN=""
+12 ; PRCA*4.5*326
FOR
SET PIEN=$ORDER(^RCY(344.6,SORT,NAME,PIEN))
if PIEN=""
QUIT
Begin DoDot:2
+13 ;
IF '$$CHKPAY(PIEN,FILTER,DATEFILT)
QUIT
+14 SET CNT=CNT+1
DO GET1PAY(PIEN,CNT)
End DoDot:2
End DoDot:1
if NAME=""
QUIT
+15 ;
QUIT
+16 ;
GET1PAY(PIEN,CNT) ; Get the data for one payer and add it to the list
+1 ; Input: PIEN - Internal entry number to file 344.6
+2 ; CNT - Incremental counter
+3 ; Output: ^TMP($J,"RCDPEPIX",CNT)=A1^A2^A3^A4^A5^A6
+4 ; Where A1=PIEN - The payer internal entry number on file 344.6
+5 ; A2=NAME - The payer name
+6 ; A3=PAYER ID (also known as TIN)
+7 ; A4=DATE ADDED
+8 ; A5=PHARMACY PAYER - A Yes/No/Null field to flag a payer as pharmacy
+9 ; A6=TRICARE PAYER - A Yes/No/Null filed to flag a payer as tricare
+10 ;
+11 NEW DATAOUT,DATEA,OUTARR,RCID,RCNAME,RCPF,RCTF
+12 DO GETS^DIQ(344.6,PIEN_",",".01;.02;.03;.09;.1","EI","OUTARR")
+13 SET RCNAME=OUTARR(344.6,PIEN_",",.01,"E")
+14 SET RCID=OUTARR(344.6,PIEN_",",.02,"E")
+15 SET DATAOUT=PIEN
+16 ; Name
SET DATAOUT=DATAOUT_"^"_RCNAME
+17 ; Payer ID
SET DATAOUT=DATAOUT_"^"_RCID
+18 ; Date added
SET DATEA=OUTARR(344.6,PIEN_",",.03,"I")
+19 ; Format as MM/DD/YY
SET DATEA=$$FMTE^XLFDT(DATEA,"2DZ")
+20 SET DATAOUT=DATAOUT_"^"_DATEA
+21 SET RCPF=$SELECT(OUTARR(344.6,PIEN_",",.09,"I"):"Y",1:"")
+22 ; Pharmacy payer flag
SET DATAOUT=DATAOUT_"^"_RCPF
+23 SET RCTF=$SELECT(OUTARR(344.6,PIEN_",",.1,"I"):"Y",1:"")
+24 ; Tricare payer flag
SET DATAOUT=DATAOUT_"^"_RCTF
+25 ; EFT ONLY PAYER/TIN
SET DATAOUT=DATAOUT_"^"_$SELECT('$DATA(^RCY(344.4,"APT",RCNAME,RCID)):"YES",1:"")
+26 SET ^TMP($JOB,"RCDPEPIX",CNT)=DATAOUT
+27 QUIT
+28 ;
CHKPAY(PIEN,FILTER,DATEFILT) ; Apply selected filters to a payer
+1 ; Input: PIEN - Internal entry number to file 344.6
+2 ; FILTER - A=All payers, P=Pharmacy payers, T=Tricare payers,
+3 ; M=Medical (Neither Pharmacy nor Tricare)
+4 ; DATEFILT - Additional Filter by Date. Has 3 pieces by '^'
+5 ; Piece 1 - 1=Filter by date, 0=Don't
+6 ; Piece 2 - START - First DATE ADDED to include(FM format)
+7 ; Piece 3 - END - Last DATE ADDED to include (FM format)
+8 ; Returns: 1 if record matches filter, otherwise 0.
+9 NEW D1,D2,DC,CREATED,MATCHT,MATCHD,PFLAG,TFLAG
+10 SET (MATCHT,MATCHD)=0
+11 ;
IF FILTER="A"
Begin DoDot:1
+12 SET MATCHT=1
End DoDot:1
+13 ;
IF '$TEST
Begin DoDot:1
+14 SET PFLAG=$$GET1^DIQ(344.6,PIEN_",",.09,"I")
+15 SET TFLAG=$$GET1^DIQ(344.6,PIEN_",",.1,"I")
+16 IF FILTER="P"
IF PFLAG
SET MATCHT=1
+17 IF FILTER="T"
IF TFLAG
SET MATCHT=1
+18 IF FILTER="M"
IF 'PFLAG
IF 'TFLAG
SET MATCHT=1
End DoDot:1
+19 ;
+20 ;
IF 'DATEFILT
Begin DoDot:1
+21 SET MATCHD=1
End DoDot:1
+22 ;
IF '$TEST
Begin DoDot:1
+23 SET D1=$PIECE(DATEFILT,"^",2)
+24 SET D2=$PIECE(DATEFILT,"^",3)
+25 SET DC=$$GET1^DIQ(344.6,PIEN_",",.03,"I")
+26 ; strip off the time portion for comparison
SET DC=$PIECE(DC,".",1)
+27 IF DC=D1!(DC=D2)!(DC>D1&(DC<D2))
SET MATCHD=1
End DoDot:1
+28 ;
+29 QUIT MATCHT&MATCHD
+30 ;
CHKKEY() ; Check security key for editing
+1 ; Inputs: None
+2 ; Returns: 1 - User has security key editing, 0 - User does not have key
+3 ;
+4 ; Always return 1 since security key is no longer required.
QUIT 1
+5 NEW RET
+6 DO OWNSKEY^XUSRB(.RET,"RCDPE PAYER IDENTIFY")
+7 ;
IF 'RET(0)
Begin DoDot:1
+8 WRITE !!,*7,">>>> Security key RCDPE PAYER IDENTIFY is required for this action"
+9 DO PAUSE^VALM1
End DoDot:1
+10 QUIT RET(0)
+11 ;
EDIT ; EP - for RCDPE PAYER FLAGS EDIT protocol
+1 ; Input: None
+2 ; Output: File 344.6 is updated
+3 ; Listman array is updated
+4 ;
+5 NEW DA,DIC,DIE,DO,DR,DTOUT,EDT,LINE,PCNT,PIEN,PROMPT,RET,SEL,X,XX,Y
+6 SET VALMBCK="R"
+7 DO FULL^VALM1
+8 ; Check security key for edit access
+9 ;
IF '$$CHKKEY()
QUIT
+10 ;
+11 SET PROMPT="Select a Payer Entry to edit: "
+12 SET PIEN=$$SELENT(1,PROMPT,VALMBG,VALMLST,.SEL,"RCDPEPIX",0)
+13 if 'PIEN
QUIT
+14 ;
+15 ; Lock Editing of this payer entry
+16 LOCK +^RCY(344.6,PIEN):3
IF '$TEST
Begin DoDot:1
+17 WRITE !!,*7,"Someone else is editing this Payer Entry."
+18 WRITE !,"Try again later."
+19 DO PAUSE^VALM1
End DoDot:1
QUIT
+20 ;
+21 ; Let the user edit the payer entry
+22 SET DIE="^RCY(344.6,"
+23 WRITE !!,"Edit flags for payer : "_$$GET1^DIQ(344.6,PIEN_",",.01,"E"),!
+24 SET DA=PIEN
+25 SET DR=".09Pharmacy Flag;.1Tricare Flag"
+26 DO ^DIE
+27 ;
+28 LOCK -^RCY(344.6,PIEN)
+29 DO GET1PAY(PIEN,+SEL)
+30 DO BLD1PAY(+SEL)
+31 QUIT
+32 ;
SELENT(FULL,PROMPT,START,END,PCNT,WLIST,MULT) ; EP - Protocol Action
+1 ; Select Entry(s) to perform an action upon
+2 ; Called from protocols : RCDPE PAYER FLAGS EDIT
+3 ; RCDPE PAYER FLAG PHARM
+4 ; RCDPE PAYER FLAG TRIC
+5 ; Input: FULL - 1 - full screen mode, 0 otherwise
+6 ; PROMPT - Prompt to be displayed to the user
+7 ; START - Starting selection value
+8 ; END - Ending selection value
+9 ; WLIST - Worklist, the user is selecting from
+10 ; Optional, defaults to 'RCDPEPIX'
+11 ; MULT - 1 to allow multiple selection,
+12 ; 0 or null otherwise
+13 ; Optional defaults to 0
+14 ; Output: PCNT - Selected Phone Book Entry line(s)
+15 ; Returns: Selected Payer Entry IEN(s)
+16 ; Error message if invalid selection
+17 NEW CTR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,PIEN,PIENS,X,XX,Y,YY
+18 if '$DATA(WLIST)
SET WLIST="RCDPEPIX"
+19 if '$DATA(MULT)
SET MULT=0
+20 if FULL
DO FULL^VALM1
+21 ; Check for multi-selection
+22 SET PCNT=$$PARSEL($GET(XQORNOD(0)),START,END)
+23 ;
+24 ; W !!!,"PCNT="_PCNT_" MULT="_MULT H 10
+25 ; Invalid multi-selection
IF 'MULT
IF $PIECE(PCNT,",",2)
Begin DoDot:1
+26 WRITE !,*7,">>>> Only single entry selection is allowed"
+27 KILL DIR
+28 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+29 if PCNT=""
SET PCNT=$$SELENTRY(PROMPT,START,END,MULT)
+30 if 'PCNT
QUIT ""
+31 ;
+32 SET PIENS=""
+33 FOR CTR=1:1:$LENGTH(PCNT,",")
Begin DoDot:1
+34 SET XX=$PIECE(PCNT,",",CTR)
+35 ;
IF XX'=""
Begin DoDot:2
+36 SET YY=$PIECE(^TMP($JOB,WLIST,XX),"^",1)
+37 SET PIENS=$SELECT(PIENS="":YY,1:PIENS_","_YY)
End DoDot:2
End DoDot:1
+38 QUIT PIENS
+39 ;
SELENTRY(PROMPT,START,END,MULT) ; Select a line
+1 ; Input: PROMPT - Prompt to be displayed to the user
+2 ; START - Start comment # that can be selected
+3 ; END - Ending comment # that can be selected
+4 ; MULT - 1=Multiple selection allowed, 0=otherwise
+5 ; Returns: Selected Comment # or "" if not selected
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET MULT=+$GET(MULT)
+8 SET DIR(0)=$SELECT(MULT:"L",1:"N")_"O^"_START_":"_END_":0"
+9 SET DIR("A")=PROMPT
+10 DO ^DIR
KILL DIR
+11 QUIT Y
+12 ;
FLAGP ; EP - for RCDPE PAYER FLAG PHARM protocol
+1 ; Toggle pharmacy flag on selected lines
+2 ; Input: None
+3 ; Output: None
+4 DO FLAG("P")
+5 QUIT
+6 ;
FLAGT ; EP - for RCDPE PAYER FLAG TRIC protocol
+1 ; Toggle Tricare flag on selected lines
+2 ; Input: None
+3 ; Output: None
+4 DO FLAG("T")
+5 QUIT
+6 ;
FLAG(TYPE) ; Flag a list of entries as Pharmacy or Tricare
+1 ; Input: TYPE - P=Pharmacy, T=Tricare
+2 ; Output: File 344.6 is updated
+3 ; ListMan array is updated
+4 NEW CONTINUE,CTR,FIELD,PERR,PIEN,PIENS,PROMPT,SELS,STOP,XX,ZS,ZZ
+5 SET FIELD=$SELECT(TYPE="P":.09,1:.1)
+6 SET VALMBCK="R"
+7 ; Check security key for edit access
+8 ;
IF '$$CHKKEY()
QUIT
+9 ;
+10 SET PROMPT="Select lines on which to toggle "
+11 SET PROMPT=PROMPT_$SELECT(TYPE="P":"Pharmacy",1:"Tricare")_" Flag"
+12 SET PIENS=$$SELENT(1,PROMPT,VALMBG,VALMLST,.SELS,"RCDPEPIX",1)
+13 ;
if PIENS=""
QUIT
+14 SET (PERR,PIEN,ZZ,ZS)=""
+15 ;
+16 ; First lock all entries to be deleted
+17 FOR CTR=1:1:$LENGTH(PIENS,",")
Begin DoDot:1
+18 ;
SET PIEN=$PIECE(PIENS,",",CTR)
IF PIEN=""
QUIT
+19 SET XX=$PIECE(SELS,",",CTR)
+20 ;
+21 ; Lock this payer exclusion for editing
+22 LOCK +^RCY(344.6,PIEN):3
IF '$TEST
Begin DoDot:2
+23 SET PERR=$SELECT(PERR="":XX,1:PERR_","_XX)
End DoDot:2
QUIT
+24 SET ZZ=$SELECT(ZZ="":PIEN,1:ZZ_","_PIEN)
+25 SET ZS=$SELECT(ZS="":XX,1:ZS_","_XX)
End DoDot:1
+26 ; Entry(s) that can be deleted
SET PIENS=ZZ
+27 SET SELS=ZS
+28 ;
+29 ; Did we lock at least one entry?
+30 IF PIENS=""
Begin DoDot:1
+31 WRITE !!,*7,"All entries are being edited by another user - Nothing done."
+32 DO PAUSE^VALM1
End DoDot:1
QUIT
+33 ;
+34 ; Next warn the user if we couldn't lock them all
+35 IF PERR'=""
Begin DoDot:1
+36 SET STOP=0
+37 WRITE !!,*7,"Warning: The following entries: ",PERR," are being edited by another user"
+38 WRITE !,"These entries will not be updated."
+39 SET CONTINUE=$$ASKYN("Continue with update of other payers?")
+40 IF 'CONTINUE
Begin DoDot:2
+41 SET STOP=1
+42 FOR CTR=1:1:$LENGTH(PIENS,",")
Begin DoDot:3
+43 SET PIEN=$PIECE(PIENS,",",CTR)
+44 LOCK -^RCY(344.6,PIEN)
End DoDot:3
End DoDot:2
End DoDot:1
if STOP
QUIT
+45 ;
+46 ; Flag selected entries
+47 ;
FOR CTR=1:1:$LENGTH(PIENS,",")
Begin DoDot:1
+48 NEW FDA,IENS,OLDVAL,VALUE
+49 SET PIEN=$PIECE(PIENS,",",CTR)
+50 SET IENS=PIEN_","
+51 SET SEL=$PIECE(SELS,",",CTR)
+52 SET OLDVAL=$$GET1^DIQ(344.6,IENS,FIELD,"I")
+53 SET VALUE=$SELECT('OLDVAL:1,1:0)
+54 SET FDA(344.6,IENS,FIELD)=VALUE
+55 LOCK -^RCY(344.6,PIEN)
+56 DO FILE^DIE("","FDA")
+57 DO GET1PAY(PIEN,SEL)
+58 DO BLD1PAY(SEL)
End DoDot:1
+59 QUIT
+60 ;
FILTER ; EP - for RCDPE PAYER FLAGS FILTER protocol
+1 ; Change the filter from a protocol
+2 ; Inputs - None
+3 ; Output - Sets variables FILTER and DATEFILT
+4 NEW NEWDATE,NEWFILT
+5 SET VALMBCK="R"
+6 DO FULL^VALM1
+7 SET NEWDATE=$$GETDATE()
+8 ;
IF NEWDATE=-1
QUIT
+9 SET NEWFILT=$$GETFILT()
+10 ;
IF NEWFILT=-1
QUIT
+11 SET DATEFILT=NEWDATE
+12 SET FILTER=NEWFILT
+13 DO HDR
DO INIT
+14 QUIT
+15 ;
PARSEL(VALMNOD,BEG,END) ; -- split out pre-answers from user
+1 ; Inputs - VALMNOD= User input from protocol menu including pre-answers
+2 ; BEG=Begining of the valid numeric range
+3 ; END=End of the valid numeric range
+4 ; Returns - Y=Comma separated list of valid numeric entries
+5 ;
+6 ; This code is adapted from VALM2.
+7 NEW I,J,L,X,Y
+8 SET Y=$TRANSLATE($PIECE($PIECE(VALMNOD,U,4),"=",2),"/\; .",",,,,,")
+9 ; Run through the list, skip invalid selections and expand ranges
+10 SET X=Y
SET Y=""
+11 ;
FOR I=1:1
SET J=$PIECE(X,",",I)
if J=""
QUIT
Begin DoDot:1
+12 ; single valid selection
IF J'["-"
IF J>(BEG-1)
IF J<(END+1)
SET Y=Y_J_","
+13 ;
IF J["-"
IF J
IF J<$PIECE(J,"-",2)
Begin DoDot:2
+14 ;
FOR L=+J:1:+$PIECE(J,"-",2)
Begin DoDot:3
+15 ; valid selection from expanded range
IF L>(BEG-1)
IF L<(END+1)
SET Y=Y_L_","
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT Y
+17 ;
PARSED(X) ; Take a date in external format and check if it is a valid
+1 ; DATE ADDED (.03) in file 344.6
+2 ; Input - Date in External format
+3 ; Output - Date in Fileman format or 0 if the input was invalid
+4 DO VAL^DIE(344.6,"+1,",.03,"",X,.RET)
+5 QUIT RET
+6 ;
ASKYN(PROMPT,DEFAULT) ; Ask a yes/no question
+1 ; Input: PROMPT - Question to be asked
+2 ; DEFAULT - Default Answer
+3 ; 1 - YES, 0 - NO
+4 ; Optional, defaults to 0
+5 ; Returns: 1 - User answered YES, 0 othewise
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 if $GET(DEFAULT)'=1
SET DEFAULT=0
+8 SET DIR(0)="Y"
SET DIR("A")=PROMPT
+9 SET DIR("B")=$SELECT(DEFAULT:"YES",1:"NO")
+10 DO ^DIR
+11 QUIT Y
+12 ;
HELP ; EP - for template RCDPE PAYER FLAGS help
+1 ; Input: None
+2 ; Output: Text from a help frame displayed to the screen
+3 NEW FILTER,DATEFILT,XQH
+4 SET VALMBCK="R"
+5 SET XQH="RCDPE PAYER FLAGS GENERAL"
+6 DO EN^XQH
+7 QUIT
+8 ;
EXIT ; -- exit code
+1 DO FULL^VALM1
+2 QUIT