- RCDPEP ;AITC/CJE - FLAG PAYERS AS PHARMACY/TRICARE ; 19-APR-2017
- ;;4.5;Accounts Receivable;**321,326,332,371,432**;;Build 16
- ;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, C=CHAMPVA payers
- ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- ; 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, C=CHAMPVA payers
- ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- 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'="","APTCM"[XX Q XX
- ;
- S DIR(0)="SA^A:All;P:Pharmacy only;T:Tricare only;C:CHAMPVA only;M:Medical"
- S DIR("A")="Select payers to show. (A)ll, (P)harmacy, (T)ricare, (C)HAMPVA, (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("?",6)=" C - Only payers flagged for CHAMPVA"
- S DIR("?")=" M - Payers NOT flagged for Pharmacy or Tricare or CHAMPVA"
- ; 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",FILTER="C":"CHAMPVA",1:"All") ;Add CHAMPVA PRCA*4.5*432
- 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
- ;PRCA*4.5*432 Decrease payer by 3 characters to make room for CHAMPVA column, Add CHAMPVA column after Tricare, Adjust column spacing
- S XX=$E(XX,1,52) ; Truncate name to 55 characters to fit ; PRCA*4.5*432 55->52
- S LINE=$$SETSTR^VALM1(XX,LINE,8,52) ; PRCA*4.5*371 - Add space for 2 extra characters to line number; PRCA*4.5*432 55->52
- S XX=$P(DATALN,"^",3) ; Payer ID
- S LINE=$$SETSTR^VALM1(XX,LINE,62,10) ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number; PRCA*4.5*432 65->62
- S XX=$P(DATALN,"^",5) ; Phamacy payer flag
- S LINE=$$SETSTR^VALM1(XX,LINE,73,2) ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number; PRCA*4.5*432 76->73
- S XX=$P(DATALN,"^",6) ; Tricare payer flag
- S LINE=$$SETSTR^VALM1(XX,LINE,76,2) ; PRCA*4.5*432 79->76
- S XX=$P(DATALN,"^",8) ; CHAMPVA payer flag ; PRCA*4.5*432 - Add CHAMPVA 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^A7^A8
- ; 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
- ; A7=EFT PAYER - A Yes/No/Null filed to flag a payer as EFT only
- ; A8=CHAMPVA PAYER - A Yes/No/Null filed to flag a payer as CHAMPVA ;PRCA*4.5*432
- ;
- N DATAOUT,DATEA,OUTARR,RCCF,RCID,RCNAME,RCPF,RCTF ;Add RCCF PRCA*4.5*432
- D GETS^DIQ(344.6,PIEN_",",".01;.02;.03;.09;.1;.15","EI","OUTARR") ;Add .15 PRCA*4.5*432
- 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 RCCF=$S(OUTARR(344.6,PIEN_",",.15,"I"):"Y",1:"") ; CHAMPVA payer flag PRCA*4.5*432
- S DATAOUT=DATAOUT_"^"_RCCF ; CHAMPVA payer flag PRCA*4.5*432
- 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, C=CHAMPVA payers
- ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- ; 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,CFLAG,CREATED,MATCHT,MATCHD,PFLAG,TFLAG ;Add CFLAG PRCA*4.5*432
- 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")
- . S CFLAG=$$GET1^DIQ(344.6,PIEN_",",.15,"I") ;Add CFLAG, CHAMPVA payer flag PRCA*4.5*432
- . I FILTER="P",PFLAG S MATCHT=1
- . I FILTER="T",TFLAG S MATCHT=1
- . I FILTER="C",CFLAG S MATCHT=1 ;CHAMPVA payer flag PRCA*4.5*432
- . I FILTER="M",'PFLAG,'TFLAG,'CFLAG S MATCHT=1 ;Add reference to 'CFLAG PRCA*4.5*432
- ;
- 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;.15CHAMPVA Flag" ;Add CHAMPVA PRCA*4.5*4.32
- 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
- ;
- FLAGC ; EP - for RCDPE PAYER FLAG CVA protocol ; Add CHAMPVA flag PRCA*4.5*432
- ; Toggle CHAMPVA flag on selected lines
- ; Input: None
- ; Output: None
- D FLAG("C")
- Q
- ;
- FLAG(TYPE) ; Flag a list of entries as Pharmacy or Tricare or CHAMPVA
- ; Input: TYPE - P=Pharmacy, T=Tricare, C=CHAMPVA
- ; 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,TYPE="T":.1,1:.15) ;Add CHAMPVA PRCA*4.5*432
- 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",TYPE="T":"Tricare",1:"CHAMPVA")_" Flag" ;Add CHAMPVA PRCA*4.5*432
- 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 18471 printed Feb 18, 2025@23:11:31 Page 2
- RCDPEP ;AITC/CJE - FLAG PAYERS AS PHARMACY/TRICARE ; 19-APR-2017
- +1 ;;4.5;Accounts Receivable;**321,326,332,371,432**;;Build 16
- +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, C=CHAMPVA payers
- +2 ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- +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, C=CHAMPVA payers
- +4 ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- +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 "APTCM"[XX
- QUIT XX
- +10 ;
- +11 SET DIR(0)="SA^A:All;P:Pharmacy only;T:Tricare only;C:CHAMPVA only;M:Medical"
- +12 SET DIR("A")="Select payers to show. (A)ll, (P)harmacy, (T)ricare, (C)HAMPVA, (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("?",6)=" C - Only payers flagged for CHAMPVA"
- +20 SET DIR("?")=" M - Payers NOT flagged for Pharmacy or Tricare or CHAMPVA"
- +21 ; S DIR("??")="RCDPE PAYER FLAGS FILTER"
- +22 ;
- +23 DO ^DIR
- +24 IF $DATA(DIRUT)
- QUIT -1
- +25 QUIT Y
- +26 ;
- 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 ;Add CHAMPVA PRCA*4.5*432
- SET FTEXT=$SELECT(FILTER="P":"Pharmacy",FILTER="T":"Tricare",FILTER="M":"Medical",FILTER="C":"CHAMPVA",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 ;PRCA*4.5*432 Decrease payer by 3 characters to make room for CHAMPVA column, Add CHAMPVA column after Tricare, Adjust column spacing
- +8 ; Truncate name to 55 characters to fit ; PRCA*4.5*432 55->52
- SET XX=$EXTRACT(XX,1,52)
- +9 ; PRCA*4.5*371 - Add space for 2 extra characters to line number; PRCA*4.5*432 55->52
- SET LINE=$$SETSTR^VALM1(XX,LINE,8,52)
- +10 ; Payer ID
- SET XX=$PIECE(DATALN,"^",3)
- +11 ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number; PRCA*4.5*432 65->62
- SET LINE=$$SETSTR^VALM1(XX,LINE,62,10)
- +12 ; Phamacy payer flag
- SET XX=$PIECE(DATALN,"^",5)
- +13 ; PRCA*4.5*371 - Move to add space for 2 extra characters to line number; PRCA*4.5*432 76->73
- SET LINE=$$SETSTR^VALM1(XX,LINE,73,2)
- +14 ; Tricare payer flag
- SET XX=$PIECE(DATALN,"^",6)
- +15 ; PRCA*4.5*432 79->76
- SET LINE=$$SETSTR^VALM1(XX,LINE,76,2)
- +16 ; CHAMPVA payer flag ; PRCA*4.5*432 - Add CHAMPVA payer flag
- SET XX=$PIECE(DATALN,"^",8)
- +17 SET LINE=$$SETSTR^VALM1(XX,LINE,79,2)
- +18 ; Date added
- SET XX=$PIECE(DATALN,"^",4)
- +19 SET LINE=$$SETSTR^VALM1(XX,LINE,82,10)
- +20 DO SET^VALM10(PAYCNT,LINE,PAYCNT)
- +21 ; EFT only payer
- SET XX=$PIECE(DATALN,"^",7)
- +22 SET LINE=$$SETSTR^VALM1(XX,LINE,93,3)
- +23 DO SET^VALM10(PAYCNT,LINE,PAYCNT)
- +24 QUIT
- +25 ;
- 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^A7^A8
- +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 ; A7=EFT PAYER - A Yes/No/Null filed to flag a payer as EFT only
- +11 ; A8=CHAMPVA PAYER - A Yes/No/Null filed to flag a payer as CHAMPVA ;PRCA*4.5*432
- +12 ;
- +13 ;Add RCCF PRCA*4.5*432
- NEW DATAOUT,DATEA,OUTARR,RCCF,RCID,RCNAME,RCPF,RCTF
- +14 ;Add .15 PRCA*4.5*432
- DO GETS^DIQ(344.6,PIEN_",",".01;.02;.03;.09;.1;.15","EI","OUTARR")
- +15 SET RCNAME=OUTARR(344.6,PIEN_",",.01,"E")
- +16 SET RCID=OUTARR(344.6,PIEN_",",.02,"E")
- +17 SET DATAOUT=PIEN
- +18 ; Name
- SET DATAOUT=DATAOUT_"^"_RCNAME
- +19 ; Payer ID
- SET DATAOUT=DATAOUT_"^"_RCID
- +20 ; Date added
- SET DATEA=OUTARR(344.6,PIEN_",",.03,"I")
- +21 ; Format as MM/DD/YY
- SET DATEA=$$FMTE^XLFDT(DATEA,"2DZ")
- +22 SET DATAOUT=DATAOUT_"^"_DATEA
- +23 SET RCPF=$SELECT(OUTARR(344.6,PIEN_",",.09,"I"):"Y",1:"")
- +24 ; Pharmacy payer flag
- SET DATAOUT=DATAOUT_"^"_RCPF
- +25 SET RCTF=$SELECT(OUTARR(344.6,PIEN_",",.1,"I"):"Y",1:"")
- +26 ; Tricare payer flag
- SET DATAOUT=DATAOUT_"^"_RCTF
- +27 ; EFT ONLY PAYER/TIN
- SET DATAOUT=DATAOUT_"^"_$SELECT('$DATA(^RCY(344.4,"APT",RCNAME,RCID)):"YES",1:"")
- +28 ; CHAMPVA payer flag PRCA*4.5*432
- SET RCCF=$SELECT(OUTARR(344.6,PIEN_",",.15,"I"):"Y",1:"")
- +29 ; CHAMPVA payer flag PRCA*4.5*432
- SET DATAOUT=DATAOUT_"^"_RCCF
- +30 SET ^TMP($JOB,"RCDPEPIX",CNT)=DATAOUT
- +31 QUIT
- +32 ;
- 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, C=CHAMPVA payers
- +3 ; M=Medical (Neither Pharmacy nor Tricare nor CHAMPVA)
- +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 ;Add CFLAG PRCA*4.5*432
- NEW D1,D2,DC,CFLAG,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 ;Add CFLAG, CHAMPVA payer flag PRCA*4.5*432
- SET CFLAG=$$GET1^DIQ(344.6,PIEN_",",.15,"I")
- +17 IF FILTER="P"
- IF PFLAG
- SET MATCHT=1
- +18 IF FILTER="T"
- IF TFLAG
- SET MATCHT=1
- +19 ;CHAMPVA payer flag PRCA*4.5*432
- IF FILTER="C"
- IF CFLAG
- SET MATCHT=1
- +20 ;Add reference to 'CFLAG PRCA*4.5*432
- IF FILTER="M"
- IF 'PFLAG
- IF 'TFLAG
- IF 'CFLAG
- SET MATCHT=1
- End DoDot:1
- +21 ;
- +22 ;
- IF 'DATEFILT
- Begin DoDot:1
- +23 SET MATCHD=1
- End DoDot:1
- +24 ;
- IF '$TEST
- Begin DoDot:1
- +25 SET D1=$PIECE(DATEFILT,"^",2)
- +26 SET D2=$PIECE(DATEFILT,"^",3)
- +27 SET DC=$$GET1^DIQ(344.6,PIEN_",",.03,"I")
- +28 ; strip off the time portion for comparison
- SET DC=$PIECE(DC,".",1)
- +29 IF DC=D1!(DC=D2)!(DC>D1&(DC<D2))
- SET MATCHD=1
- End DoDot:1
- +30 ;
- +31 QUIT MATCHT&MATCHD
- +32 ;
- 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 ;Add CHAMPVA PRCA*4.5*4.32
- SET DR=".09Pharmacy Flag;.1Tricare Flag;.15CHAMPVA 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 ;
- FLAGC ; EP - for RCDPE PAYER FLAG CVA protocol ; Add CHAMPVA flag PRCA*4.5*432
- +1 ; Toggle CHAMPVA flag on selected lines
- +2 ; Input: None
- +3 ; Output: None
- +4 DO FLAG("C")
- +5 QUIT
- +6 ;
- FLAG(TYPE) ; Flag a list of entries as Pharmacy or Tricare or CHAMPVA
- +1 ; Input: TYPE - P=Pharmacy, T=Tricare, C=CHAMPVA
- +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 ;Add CHAMPVA PRCA*4.5*432
- SET FIELD=$SELECT(TYPE="P":.09,TYPE="T":.1,1:.15)
- +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 ;Add CHAMPVA PRCA*4.5*432
- SET PROMPT=PROMPT_$SELECT(TYPE="P":"Pharmacy",TYPE="T":"Tricare",1:"CHAMPVA")_" 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