FBUTL136 ;DSS/LJF - FEE BASIS UTILITY FOR UNIQUE CLAIM ID - FEE5010 (overflow from FBUTL135) ;3/23/2012
;;3.5;FEE BASIS;**135**;MAR 23, 2012;Build 3
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
;--------------------- OUTPATIENT ----------------------------------------
;
ENTROUTP(DFN,FBV,FBAAVID,FBCLAIMS) ; OUTPATIENT ENTER UCID
; Input: DFN - Patient ID
; FBV - Vendor IEN
; FBAAVID - Vendor Invoice Date
; FBCLAIMS - FPPS claim id
; Output: returns UCID
;
N FBCLT,FBTOUT
I $G(DFN),$G(FBV),$G(FBAAVID) S FBCLAIMS=$G(FBCLAIMS),FBCLT="",DTIME=$G(DTIME,300),FBTOUT=""
E Q "-1"
;
I FBCLAIMS="N/A" S FBCLAIMS=""
I FBCLAIMS]"" D Q FBCLAIMS
. S FBCLAIMS=+$P($$HTE^XLFDT($H)," ",3)_"-"_FBCLAIMS
. S FBCLT=$$OCLMTYP^FBUTL135
. S FBCLAIMS=$$UCLAIMNO^FBUTL135($G(FBSTA),1,"E",FBCLT,FBCLAIMS)
;
F R !,"CLAIM NUMBER: ",FBANS:DTIME S FBTOUT='$T D I FBANS]"" S FBCLAIMS=FBANS Q
. I FBTOUT S FBANS="-1" Q
. I $TR(FBANS,"new","NEW")="NEW" D Q
.. S FBANS=$$UCLAIMNO^FBUTL135 W "#: "_$E(FBANS,9,28)
.. S $E(FBANS,8)=$$OCLMTYP^FBUTL135
. I FBANS="??" D W ! I FBANS="" Q ; if no claim returns claim# - reask claim number
.. S FBANS=$$OUTPHELP(DFN,FBV) I FBANS<1 S FBANS="" Q
.. S FBCLT=$P(FBANS,U,2),FBANS=$P(FBANS,U)
. I $E(FBANS)="^" S FBANS="" W !!,"This is a required response. ""^"" is not allowed.",! Q
. I FBANS="?" D S FBANS="" Q
.. W !!,"Enter ""NEW"" to automatically generate a new claim number,"
.. W !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
.. W !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
. I FBANS="" W !!,"This is a required response.",! Q
. I FBANS'?4N1"-"1.15N W !!,"** INVALID CLAIM NUMBER **",!! S FBANS="" Q
. S FBANS=$$UCLAIMNO^FBUTL135(,,,$G(FBCLT),FBANS)
. S $E(FBANS,8)=$$OCLMTYP^FBUTL135
. I FBANS'?6N2UL4N1"-"1.15N W !!,"** INVALID CLAIM NUMBER ***",!! S (FBANS,FBCLT)=""
Q FBCLAIMS
;
EDITOUTP(FBXSTR,FBDA) ;
; Inputs: FBXSTR = FPPS CLAIM ID entered by user
; FBDA = DA variable containing SERVICE PROVIDED, INITIAL TREATMENT DATE, VENDOR, PATIENT
;
N FBPAT,FBVEND,FBTDTG,FBSERVSE,DA,DR,FBINTYP
S FBSERVSE=$G(FBDA)
S FBTDTG=$G(FBDA(1))
S FBVEND=$G(FBDA(2))
S FBPAT=$G(FBDA(3))
S FBXSTR=$G(FBXSTR)
I FBXSTR'=-1,FBPAT,FBVEND,FBTDTG,FBSERVSE
E Q
N FBDA ; New it so we don't affect it in any way
N FBDATA,FBSTA,FBSITE,FPPSCLM,FBICLAIM,FBSRC,FBINT,FBCLT,FBCLAIMS,FBPRMPT,FBHOLD,C
S C=",",FBSTA=$$STATION^FBUTL135,(FBHOLD,FBICLAIM)=""
S FPPSCLM=$$GET1^DIQ(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,50,"I") ; get current value of FPPS claim id
;
I FBXSTR]"" D Q ; If user entered FPPS, create UCID, save, and quit
. S FBICLAIM=+$P($$HTE^XLFDT($H)," ",3)_"-"_FBXSTR
. ; get claim type
. S FBCLT=$$OCLMTYP^FBUTL135($G(FBCLT))
. S FBICLAIM=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,1,"E",FBCLT,FBICLAIM) ; Populate UCID field
; If user didn't enter a new FPPS CLAIM ID
I FBXSTR="" D
. ;If FPPS CLAIM ID field is populated, clear out exisitng UCID and prepare for new one
. I FPPSCLM]"" S FBICLAIM(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,81)="" D FILE^DIE(,"FBICLAIM") K FBICLAIM S FBICLAIM="" Q
. ;FPPS CLAIM ID field is null get existing UCID for default
. S FBICLAIM=$$GET1^DIQ(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,81,"I")
. I $E(FBICLAIM,7)'="M" S FBICLAIM="" Q ; if not a manual claim, don't use it
;
I FBICLAIM="" D Q ; If UCID not populated
. F S FBICLAIM=$$ENTROUTP(FBPAT,FBVEND,FBTDTG) W:FBICLAIM<1 !," REQUIRED ENTRY." Q:FBICLAIM<1 D Q:FBICLAIM>1 ; allow user to enter new UCID
.. S FBSTA=$E(FBICLAIM,1,5)
.. S FBSRC=$E(FBICLAIM,6)
.. S FBINTYP=$E(FBICLAIM,7)
.. S FBCLT=$E(FBICLAIM,8)
.. S $E(FBICLAIM,1,8)=""
.. S FBICLAIM=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,FBSRC,FBINTYP,FBCLT,FBICLAIM) ; Populate UCID field
;
; we have an existing UCID - validate it then allow edit
I '$$VALIDATE^FBUTL135("O",FBICLAIM) S FBICLAIM="" ; not valid -
E D
. S FBSTA=$E(FBICLAIM,1,5)
. S FBSRC=$E(FBICLAIM,6)
. S FBINT=$E(FBICLAIM,7)
. S FBCLT=$E(FBICLAIM,8)
. S $E(FBICLAIM,1,8)="",FBHOLD=FBICLAIM
;
I FBICLAIM]"" S FBPRMPT=" "_FBICLAIM_" //"
S FBPRMPT="CLAIM NUMBER:"_$G(FBPRMPT)_" ",FBTOUT=""
F W !,FBPRMPT R FBANS:DTIME S FBTOUT='$T Q:FBTOUT D Q:FBTOUT I FBANS'="" S FBCLAIMS=FBANS Q
. I FBANS="",FBICLAIM]"" D
.. S FBANS=FBICLAIM
. I $TR(FBANS,"new","NEW")="NEW" D Q
.. S (FBSTA,FBSRC)="",FBINTYP="M",FBANS=$$UCLAIMNO^FBUTL135() W "#: "_$E(FBANS,9,28)
. I FBANS="??" D I FBANS="" Q
.. S FBANS=$$OUTPHELP(FBPAT,FBVEND) I FBANS<1 S FBANS="" Q
.. S FBCLT=$P(FBANS,U,2),FBANS=$P(FBANS,U)
. I FBANS="@" W !!," REQUIRED ENTRY.",! S FBANS="" Q
. I $E(FBANS)="^" S FBANS="" W !!,"This is a required response. ""^"" is not allowed.",! Q
. I FBANS="?" D S FBANS="" Q
.. W !!,"Enter ""NEW"" to automatically generate a new claim number,"
.. W !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
.. W !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
. I FBANS="" S FBANS=FBHOLD
. I FBANS?4N1"-"1.15N D
.. S FBANS=$$UCLAIMNO^FBUTL135($G(FBSITE),$G(FBSRC),$G(FBINT),$G(FBCLT),FBANS)
. I FBANS'?6N2UL4N1"-"1.15N W !!,"** INVALID CLAIM NUMBER ****",!! S FBANS=""
I FBTOUT S DTOUT=FBTOUT,FBXSTR=-1 Q ; flag not to save FPPS EDIT
I $G(FBCLAIMS)]"" D I FBCLAIMS Q
. S FBSTA=$E(FBCLAIMS,1,5)
. S FBSRC=$E(FBCLAIMS,6)
. S FBINT=$E(FBCLAIMS,7)
. S FBCLT=$$OCLMTYP^FBUTL135($E(FBCLAIMS,8))
. S $E(FBCLAIMS,1,8)=""
. S FBCLAIMS=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,FBSRC,FBINT,FBCLT,FBCLAIMS)
. I FBCLAIMS<1 S FBCLAIMS=""
;
N DA
S DA=$G(FBSERVSE)
S DA(1)=$G(FBTDTG)
S DA(2)=$G(FBVEND)
S DA(3)=$G(FBPAT)
S FBXSTR=$G(FBXSTR)
W !!,"** INVALID CLAIM NUMBER *****",!! D EDITOUTP(FBXSTR,.DA) ; Restart edit
Q
OUTPHELP(DFN,FBV) ; ?? response
I $G(DFN),$G(FBV) ; gotta have a DFN, and a Vendor number
E Q 0
N DTG,E7,E7TEXT,FBINT,FBIX,RETDIR,FBVENDT
N DTOUT,DUOUT,DIRUT,DIROUT,X,Y,C
N FBDOS,FBSVC,UCID,FBYEAR,OLINE,CNT,CLMID,CLMTYP
S FBTOUT=""
S E7TEXT("E")="1-EDI",E7TEXT("S")="2-SCANNED",E7TEXT("M")="3-MANUAL"
S (CNT,DTG)=0,RETDIR="",C=","
S FBDOS=0
F S FBDOS=$O(^FBAAC(DFN,1,FBV,1,FBDOS)),FBSVC=0 Q:'FBDOS D ; date of service
. F S FBSVC=$O(^FBAAC(DFN,1,FBV,1,FBDOS,1,FBSVC)) Q:'FBSVC D ; service provided
.. S UCID=$P($G(^FBAAC(DFN,1,FBV,1,FBDOS,1,FBSVC,5)),U,5)
.. I UCID="" Q
.. I '$$VALIDATE^FBUTL135("O",UCID) Q
.. I $E(UCID,7)="E" Q ; Quit if Initiation Type is "E"DI
.. S CLMTYP=$E(UCID,8)
.. S FBYEAR=$$FMTE^XLFDT(FBDOS),FBVENDT=$$GET1^DIQ(162.02,FBDOS_C_FBV_C_DFN_C,.01,"I")
.. S CLMID=$E(UCID,9,28) ; Only want the YYYY-<xxxxx>
.. S OLINE=$E(CLMID_" ",1,22)
.. S OLINE=OLINE_$E(FBVENDT_" ",1,14) ; Vendor date
.. S OLINE=OLINE_"("_UCID_")" ; Full UCID
.. S UCID("LIST",9999999-FBVENDT,FBSVC,CLMID)=OLINE_"^^"_CLMTYP
;
I '$D(UCID("LIST")) W !!,?5,"NO RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR" Q "" ; Nothing to display
E W !!,?4,"RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",!
K OLINE S OLINE=$NA(UCID("LIST"))
; Display list of prospects
F CNT=1:1 S OLINE=$Q(@OLINE) Q:OLINE="" D Q:RETDIR Q:$G(DTOUT) Q:$G(DUOUT)
. I '(CNT-1#5) W !," # CLAIM NO VEND INV DATE COMPLETE UCID"
. S CNT(CNT)=$J(CNT,2)_": "_$P(@OLINE,"^^"),CNT(CNT,"CLMID")=$QS(OLINE,4)_U_$P(@OLINE,"^^",2) W !,CNT(CNT)
. I '(CNT#5) D
.. N DA,DIR
.. S DIR(0)="NAO^1:"_CNT,DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or",DIR("A")="CHOOSE 1-"_CNT_": " D ^DIR
.. ;Possible options - X is a number = done. or X is null or X is "^"
.. I X?1.2N S RETDIR=X Q
I '$G(DTOUT),'$G(DUOUT)
E S RETDIR="-1^"_$G(DTOUT)_"."_$G(DUOUT) K DTOUT,DUOUT Q RETDIR ; time out or opt out
; no opt out, no time out
I 'RETDIR D ; user did not select any entries so far, so display final choice prompt
. N DA,DIR
. S CNT=CNT-1,DIR(0)="NAO^1:"_CNT,DIR("A",1)="Press <RETURN> to return to main prompt, or",DIR("A")="CHOOSE 1-"_CNT_":" D ^DIR
. I X?1.2N S RETDIR=X
I '$G(DTOUT),'$G(DUOUT)
E S RETDIR="-1^"_$G(DTOUT)_"."_$G(DUOUT) K DTOUT,DUOUT Q RETDIR ; time out or opt out
I RETDIR Q $G(CNT(RETDIR,"CLMID")) ; quit with the selected claim
Q RETDIR
;
;
;--------------------- INPATIENT ----------------------------------------
;
ENTINPAT(FBSTA,FBSRC,FBINT,FBCLT,FBCLAIMS,FBVEND) ;Returns UCID; FB*3.5*135
; Input: FBSTA = Station
; FBSRC = Source
; FBINT = Initiation Type
; FBCLT = Claim Type
; FBCLAIMS = FPPS CLAIM ID - replaces sequence number
; FBVEND = Vendor IEN
;
; Output: UCID
;
N FBRETVAL,FBTOUT,FBANS
K DTOUT
S FBSTA=$G(FBSTA),FBSRC=$G(FBSRC),FBINT=$G(FBINT),FBCLT=$G(FBCLT),FBCLAIMS=$G(FBCLAIMS),FBVEND=$G(FBVEND),(FBRETVAL,FBTOUT,FBUOUT,FBANS)=""
I FBCLAIMS="N/A" S FBCLAIMS=""
I FBCLAIMS]"" D Q FBCLAIMS
. S FBCLAIMS=+$P($$HTE^XLFDT($H)," ",3)_"-"_FBCLAIMS
. S FBCLAIMS=$$UCLAIMNO^FBUTL135(FBSTA,FBSRC,"E",FBCLT,FBCLAIMS)
F R !,"CLAIM NUMBER: ",FBANS:DTIME S FBTOUT='$T Q:FBTOUT D Q:FBTOUT I FBANS'="" S FBCLAIMS=FBANS Q
. I $TR(FBANS,"new","NEW")="NEW" S FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$G(FBSRC),"M",$G(FBCLT)) W "#: "_$E(FBANS,9,28) Q
. I FBANS="??" S FBANS=$$ENTHELP(FBVEND,.FBTOUT,.FBUOUT) S:FBUOUT (FBANS,FBUOUT)="" Q:FBANS=""
. I $E(FBANS)="^" S FBANS="" W !!,"This is a required response. ""^"" is not allowed.",! Q
. I FBANS="?" D S FBANS="" Q
.. W !!,"Enter ""NEW"" to automatically generate a new claim number,"
.. W !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
.. W !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
. I FBANS="" W !!," REQUIRED ENTRY.",! Q
. I FBANS?4N1"-"1.15N S FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$G(FBSRC),$G(FBINT),$G(FBCLT),FBANS)
. I FBANS'?6N2UL4N1"-"1.15N W !!,"*** INVALID CLAIM NUMBER ***",!! S FBANS=""
I 'FBTOUT,'FBUOUT Q FBCLAIMS
I FBTOUT S DTOUT=FBTOUT
I FBUOUT S DUOUT=FBUOUT
Q ""
;
ENTHELP(FBVEND,FBTOUT,FBUOUT) ; Help for UCID in "FBCH ENTER PAYMENT" ; FB*3.5*135
I $G(DFN),$G(FBVEND) ; gotta have a DFN, and a Vendor number
E Q 0
N CLMID,CNT,DTG,E7,E7TEXT,FBINT,FBIX,OLINE,RETDIR,UCIDLIST,YR
N DTOUT,DUOUT,DIRUT,DIROUT,X,Y
S (FBTOUT,FBUOUT)=""
S E7TEXT("E")="1-EDI",E7TEXT("S")="2-SCANNED",E7TEXT("M")="3-MANUAL"
S (CNT,DTG)=0,RETDIR=""
; Build list of prospects
F S DTG=$O(^FBAAI("AG",DFN,DTG)),FBIX=0 Q:'DTG D
. F S FBIX=$O(^FBAAI("AG",DFN,DTG,FBIX)) Q:'FBIX D
.. K FBINT D GETS^DIQ(162.5,FBIX,"2;46;85","IE","FBINT")
.. I FBINT("162.5",FBIX_",",2,"I")'=FBVEND Q ; Quit if vendor doesn't match
.. I FBINT("162.5",FBIX_",",85,"E")="" Q ; Quit if no UCID
.. I $E(FBINT("162.5",FBIX_",",85,"E"),7)="E" Q ; Quit if Initiation Type is "E"DI
.. I '$$VALIDATE^FBUTL135("I",FBINT("162.5",FBIX_",",85,"E")) Q ; Quit if not valid
.. K OLINE M OLINE=FBINT("162.5",FBIX_",")
.. S UCIDLIST=FBINT("162.5",FBIX_",",85,"E")
.. S YR=(9999999.999999-$G(OLINE(46,"I"))),CLMID=$P(UCIDLIST,"-",1,2),E7=$E(UCIDLIST,7)
.. I $D(E7TEXT(E7)) S E7=E7TEXT(E7)
.. E S E7="4-"_E7
.. S OLINE=$E($G(OLINE(85,"E"))_" ",9,30) ; Only want the YYYY-<xxxxx>
.. S OLINE=OLINE_$E($G(OLINE(46,"E"))_" ",1,14) ; Vendor date
.. S OLINE=OLINE_"("_$G(OLINE(85,"E"))_")" ; Full UCID
.. S UCIDLIST("LIST",YR,E7,CLMID,FBIX)=OLINE
K OLINE S OLINE=$NA(UCIDLIST("LIST"))
I '$D(UCIDLIST("LIST")) W !!,?5,"NO RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",! Q "" ; Nothing to display
E W !!,?4,"RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",!
; Display list of prospects
F CNT=1:1 S OLINE=$Q(@OLINE) Q:OLINE="" D Q:RETDIR Q:$G(DTOUT) Q:$G(DUOUT)
. I '(CNT-1#5) W !," # CLAIM NO VEND INV DATE COMPLETE UCID"
. S CNT(CNT)=$J(CNT,2)_": "_@OLINE,CNT(CNT,"CLMID")=$QS(OLINE,4)_U_$QS(OLINE,3) W !,CNT(CNT)
. I '(CNT#5) D
.. N DA,DIR
.. S DIR(0)="NAO^1:"_CNT,DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or",DIR("A")="CHOOSE 1-"_CNT_": " D ^DIR
.. ;Possible options - X is a number = done. or X is null or X is "^"
.. I X?1.2N S RETDIR=X Q
S FBTOUT=$G(DTOUT),FBUOUT=$G(DUOUT)
I 'FBTOUT,'FBUOUT
E Q "" ; time out or opt out
; no opt out, no time out
I 'RETDIR D ; user did not select any entries so far, so display final choice prompt
. N DA,DIR
. S CNT=CNT-1,DIR(0)="NAO^1:"_CNT,DIR("A",1)="Press <RETURN> to return to main prompt, or",DIR("A")="CHOOSE 1-"_CNT_":" D ^DIR
. I X?1.2N S RETDIR=X
S FBTOUT=$G(DTOUT),FBUOUT=$G(DUOUT)
I 'FBTOUT,'FBUOUT
E Q "" ; time out or opt out
I RETDIR Q $P($G(CNT(RETDIR,"CLMID")),U) ; quit with the selected claim
Q RETDIR
;
EDINPAT(FBXSTR,FBI) ; EDIT UNIQUE CLAIM ID for FEE BASIS INVOICE file - 162.5
; Input: FBXSTR = FPPS value entered by user for FPPS
; FBI = IEN of Invoice record
;
; Output: UCID
;
N FBDATA,FBFPPSCL,FBICLAIM,FBSITE,FBSTA,FBSRC,FBINT,FBCLT,FPPSCLM,FBCLAIMS,FBPRMPT,FBHOLD,FBVEND
S FBXSTR=$G(FBXSTR),FBI=$G(FBI),FBSTA=$$STATION^FBUTL135,FBVEND=$$GET1^DIQ(162.5,FBI_",",2,"I"),FPPSCLM=$$GET1^DIQ(162.5,FBI_",",56,"I"),(FBHOLD,FBICLAIM)=""
I FBXSTR'=-1,FBI
E Q
;
I FBXSTR]"" D Q ; If user entered FPPS, create UCID, save, and quit
. S FBICLAIM=+$P($$HTE^XLFDT($H)," ",3)_"-"_FBXSTR
. S FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSTA,1,"E",FBICLAIM) ; Populate UCID field
;
; If user didn't enter a new FPPS CLAIM ID
I FBXSTR="" D
. ;If FPPS CLAIM ID field is populated, clear out exisitng UCID and prepare for new one
. I FPPSCLM]"" S FBICLAIM(162.5,FBI_",",85)="" D FILE^DIE(,"FBICLAIM") K FBICLAIM S FBICLAIM="" Q
. ;FPPS CLAIM ID field is null get existing UCID for default
. S FBICLAIM=$$GET1^DIQ(162.5,FBI_",",85,"I") I $E(FBICLAIM,7)'="M" S FBICLAIM="" ; if not a manual claim, don't use it
;
I FBICLAIM="" D Q ; If UCID not populated
. S FBICLAIM=$$ENTINPAT(,1,"M","I",,FBVEND) ; allow user to enter new UCID
. I '$G(DTOUT),'$G(DUOUT),FBICLAIM]"" D
.. S FBSITE=$E(FBICLAIM,1,5)
.. S FBSRC=$E(FBICLAIM,6)
.. S FBINT=$E(FBICLAIM,7)
.. S $E(FBICLAIM,1,8)=""
.. S FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSITE,FBSRC,FBINT,FBICLAIM) ; Populate UCID field
; we have an existing UCID - validate it then allow edit
;
I '$$VALIDATE^FBUTL135("I",FBICLAIM) S FBICLAIM="" ; not valid -
E D
. S FBSITE=$E(FBICLAIM,1,5) I FBSITE="" S FBSITE=FBSTA
. S FBSRC=$E(FBICLAIM,6) I FBSRC="" S FBSRC=1
. S FBINT=$E(FBICLAIM,7) I FBINT="" S FBINT="M"
. S FBCLT="I"
. S $E(FBICLAIM,1,8)="",FBHOLD=FBICLAIM
;
I FBICLAIM]"" S FBPRMPT=" "_FBICLAIM_" //"
S FBPRMPT="CLAIM NUMBER:"_$G(FBPRMPT)_" ",(FBTOUT,FBUOUT)=""
F W !,FBPRMPT R FBANS:DTIME S FBTOUT='$T Q:FBTOUT D Q:FBTOUT Q:FBUOUT I FBANS'="" S FBCLAIMS=FBANS Q
. I FBANS="",'FBTOUT,FBICLAIM]"" S FBANS=FBICLAIM Q ; accept existing UCID suffix
. I $TR(FBANS,"new","NEW")="NEW" S FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$G(FBSRC),$G(FBINT),$G(FBCLT)) W "#: "_$E(FBANS,9,28) Q
. I FBANS="??" D Q:FBANS=""
.. S FBANS=$$ENTHELP(FBVEND,.FBTOUT,.FBUOUT)
.. I FBTOUT S (FBTOUT,FBANS)="" Q
.. I FBUOUT Q
.. I FBANS="" Q
. I FBANS="@" W !!," REQUIRED ENTRY.",! S FBANS="" Q
. I $E(FBANS)="^" S FBANS="" W !!,"This is a required response. ""^"" is not allowed.",! Q
. I FBANS="?" D S FBANS="" Q
.. W !!,"Enter ""NEW"" to automatically generate a new claim number,"
.. W !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
.. W !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
. I FBANS="" S FBANS=FBHOLD Q
. I FBANS?4N1"-"1.15N S FBANS=$$UCLAIMNO^FBUTL135($G(FBSITE),$G(FBSRC),$G(FBINT),$G(FBCLT),FBANS)
. I FBANS'?6N2UL4N1"-"1.15N W !!,"*** INVALID CLAIM NUMBER ****",!! S FBANS="" Q
I FBTOUT S DTOUT=FBTOUT,FBX=-1 ; flag not to save FPPS EDIT
I FBUOUT S DUOUT=FBUOUT,FBX=-1 ; flag not to save FPPS EDIT
I 'FBTOUT,'FBUOUT D
. I FBANS?4N1"-"1.15N D
.. S FBANS=FBSTA_"1MI"_FBANS
. S FBSTA=$E(FBANS,1,5)
. S FBSRC=$E(FBANS,6)
. S FBINT=$E(FBANS,7)
. S $E(FBANS,1,8)=""
. S FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSTA,FBSRC,FBINT,FBANS)
. I +FBICLAIM=-1 W !!,"*** INVALID CLAIM NUMBER *****",!! D EDINPAT(FBXSTR,FBI) ; Populate UCID field
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUTL136 16550 printed Sep 23, 2025@19:36:48 Page 2
FBUTL136 ;DSS/LJF - FEE BASIS UTILITY FOR UNIQUE CLAIM ID - FEE5010 (overflow from FBUTL135) ;3/23/2012
+1 ;;3.5;FEE BASIS;**135**;MAR 23, 2012;Build 3
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;--------------------- OUTPATIENT ----------------------------------------
+6 ;
ENTROUTP(DFN,FBV,FBAAVID,FBCLAIMS) ; OUTPATIENT ENTER UCID
+1 ; Input: DFN - Patient ID
+2 ; FBV - Vendor IEN
+3 ; FBAAVID - Vendor Invoice Date
+4 ; FBCLAIMS - FPPS claim id
+5 ; Output: returns UCID
+6 ;
+7 NEW FBCLT,FBTOUT
+8 IF $GET(DFN)
IF $GET(FBV)
IF $GET(FBAAVID)
SET FBCLAIMS=$GET(FBCLAIMS)
SET FBCLT=""
SET DTIME=$GET(DTIME,300)
SET FBTOUT=""
+9 IF '$TEST
QUIT "-1"
+10 ;
+11 IF FBCLAIMS="N/A"
SET FBCLAIMS=""
+12 IF FBCLAIMS]""
Begin DoDot:1
+13 SET FBCLAIMS=+$PIECE($$HTE^XLFDT($HOROLOG)," ",3)_"-"_FBCLAIMS
+14 SET FBCLT=$$OCLMTYP^FBUTL135
+15 SET FBCLAIMS=$$UCLAIMNO^FBUTL135($GET(FBSTA),1,"E",FBCLT,FBCLAIMS)
End DoDot:1
QUIT FBCLAIMS
+16 ;
+17 FOR
READ !,"CLAIM NUMBER: ",FBANS:DTIME
SET FBTOUT='$TEST
Begin DoDot:1
+18 IF FBTOUT
SET FBANS="-1"
QUIT
+19 IF $TRANSLATE(FBANS,"new","NEW")="NEW"
Begin DoDot:2
+20 SET FBANS=$$UCLAIMNO^FBUTL135
WRITE "#: "_$EXTRACT(FBANS,9,28)
+21 SET $EXTRACT(FBANS,8)=$$OCLMTYP^FBUTL135
End DoDot:2
QUIT
+22 ; if no claim returns claim# - reask claim number
IF FBANS="??"
Begin DoDot:2
+23 SET FBANS=$$OUTPHELP(DFN,FBV)
IF FBANS<1
SET FBANS=""
QUIT
+24 SET FBCLT=$PIECE(FBANS,U,2)
SET FBANS=$PIECE(FBANS,U)
End DoDot:2
WRITE !
IF FBANS=""
QUIT
+25 IF $EXTRACT(FBANS)="^"
SET FBANS=""
WRITE !!,"This is a required response. ""^"" is not allowed.",!
QUIT
+26 IF FBANS="?"
Begin DoDot:2
+27 WRITE !!,"Enter ""NEW"" to automatically generate a new claim number,"
+28 WRITE !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
+29 WRITE !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
End DoDot:2
SET FBANS=""
QUIT
+30 IF FBANS=""
WRITE !!,"This is a required response.",!
QUIT
+31 IF FBANS'?4N1"-"1.15N
WRITE !!,"** INVALID CLAIM NUMBER **",!!
SET FBANS=""
QUIT
+32 SET FBANS=$$UCLAIMNO^FBUTL135(,,,$GET(FBCLT),FBANS)
+33 SET $EXTRACT(FBANS,8)=$$OCLMTYP^FBUTL135
+34 IF FBANS'?6N2UL4N1"-"1.15N
WRITE !!,"** INVALID CLAIM NUMBER ***",!!
SET (FBANS,FBCLT)=""
End DoDot:1
IF FBANS]""
SET FBCLAIMS=FBANS
QUIT
+35 QUIT FBCLAIMS
+36 ;
EDITOUTP(FBXSTR,FBDA) ;
+1 ; Inputs: FBXSTR = FPPS CLAIM ID entered by user
+2 ; FBDA = DA variable containing SERVICE PROVIDED, INITIAL TREATMENT DATE, VENDOR, PATIENT
+3 ;
+4 NEW FBPAT,FBVEND,FBTDTG,FBSERVSE,DA,DR,FBINTYP
+5 SET FBSERVSE=$GET(FBDA)
+6 SET FBTDTG=$GET(FBDA(1))
+7 SET FBVEND=$GET(FBDA(2))
+8 SET FBPAT=$GET(FBDA(3))
+9 SET FBXSTR=$GET(FBXSTR)
+10 IF FBXSTR'=-1
IF FBPAT
IF FBVEND
IF FBTDTG
IF FBSERVSE
+11 IF '$TEST
QUIT
+12 ; New it so we don't affect it in any way
NEW FBDA
+13 NEW FBDATA,FBSTA,FBSITE,FPPSCLM,FBICLAIM,FBSRC,FBINT,FBCLT,FBCLAIMS,FBPRMPT,FBHOLD,C
+14 SET C=","
SET FBSTA=$$STATION^FBUTL135
SET (FBHOLD,FBICLAIM)=""
+15 ; get current value of FPPS claim id
SET FPPSCLM=$$GET1^DIQ(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,50,"I")
+16 ;
+17 ; If user entered FPPS, create UCID, save, and quit
IF FBXSTR]""
Begin DoDot:1
+18 SET FBICLAIM=+$PIECE($$HTE^XLFDT($HOROLOG)," ",3)_"-"_FBXSTR
+19 ; get claim type
+20 SET FBCLT=$$OCLMTYP^FBUTL135($GET(FBCLT))
+21 ; Populate UCID field
SET FBICLAIM=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,1,"E",FBCLT,FBICLAIM)
End DoDot:1
QUIT
+22 ; If user didn't enter a new FPPS CLAIM ID
+23 IF FBXSTR=""
Begin DoDot:1
+24 ;If FPPS CLAIM ID field is populated, clear out exisitng UCID and prepare for new one
+25 IF FPPSCLM]""
SET FBICLAIM(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,81)=""
DO FILE^DIE(,"FBICLAIM")
KILL FBICLAIM
SET FBICLAIM=""
QUIT
+26 ;FPPS CLAIM ID field is null get existing UCID for default
+27 SET FBICLAIM=$$GET1^DIQ(162.03,FBSERVSE_C_FBTDTG_C_FBVEND_C_FBPAT_C,81,"I")
+28 ; if not a manual claim, don't use it
IF $EXTRACT(FBICLAIM,7)'="M"
SET FBICLAIM=""
QUIT
End DoDot:1
+29 ;
+30 ; If UCID not populated
IF FBICLAIM=""
Begin DoDot:1
+31 ; allow user to enter new UCID
FOR
SET FBICLAIM=$$ENTROUTP(FBPAT,FBVEND,FBTDTG)
if FBICLAIM<1
WRITE !," REQUIRED ENTRY."
if FBICLAIM<1
QUIT
Begin DoDot:2
+32 SET FBSTA=$EXTRACT(FBICLAIM,1,5)
+33 SET FBSRC=$EXTRACT(FBICLAIM,6)
+34 SET FBINTYP=$EXTRACT(FBICLAIM,7)
+35 SET FBCLT=$EXTRACT(FBICLAIM,8)
+36 SET $EXTRACT(FBICLAIM,1,8)=""
+37 ; Populate UCID field
SET FBICLAIM=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,FBSRC,FBINTYP,FBCLT,FBICLAIM)
End DoDot:2
if FBICLAIM>1
QUIT
End DoDot:1
QUIT
+38 ;
+39 ; we have an existing UCID - validate it then allow edit
+40 ; not valid -
IF '$$VALIDATE^FBUTL135("O",FBICLAIM)
SET FBICLAIM=""
+41 IF '$TEST
Begin DoDot:1
+42 SET FBSTA=$EXTRACT(FBICLAIM,1,5)
+43 SET FBSRC=$EXTRACT(FBICLAIM,6)
+44 SET FBINT=$EXTRACT(FBICLAIM,7)
+45 SET FBCLT=$EXTRACT(FBICLAIM,8)
+46 SET $EXTRACT(FBICLAIM,1,8)=""
SET FBHOLD=FBICLAIM
End DoDot:1
+47 ;
+48 IF FBICLAIM]""
SET FBPRMPT=" "_FBICLAIM_" //"
+49 SET FBPRMPT="CLAIM NUMBER:"_$GET(FBPRMPT)_" "
SET FBTOUT=""
+50 FOR
WRITE !,FBPRMPT
READ FBANS:DTIME
SET FBTOUT='$TEST
if FBTOUT
QUIT
Begin DoDot:1
+51 IF FBANS=""
IF FBICLAIM]""
Begin DoDot:2
+52 SET FBANS=FBICLAIM
End DoDot:2
+53 IF $TRANSLATE(FBANS,"new","NEW")="NEW"
Begin DoDot:2
+54 SET (FBSTA,FBSRC)=""
SET FBINTYP="M"
SET FBANS=$$UCLAIMNO^FBUTL135()
WRITE "#: "_$EXTRACT(FBANS,9,28)
End DoDot:2
QUIT
+55 IF FBANS="??"
Begin DoDot:2
+56 SET FBANS=$$OUTPHELP(FBPAT,FBVEND)
IF FBANS<1
SET FBANS=""
QUIT
+57 SET FBCLT=$PIECE(FBANS,U,2)
SET FBANS=$PIECE(FBANS,U)
End DoDot:2
IF FBANS=""
QUIT
+58 IF FBANS="@"
WRITE !!," REQUIRED ENTRY.",!
SET FBANS=""
QUIT
+59 IF $EXTRACT(FBANS)="^"
SET FBANS=""
WRITE !!,"This is a required response. ""^"" is not allowed.",!
QUIT
+60 IF FBANS="?"
Begin DoDot:2
+61 WRITE !!,"Enter ""NEW"" to automatically generate a new claim number,"
+62 WRITE !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
+63 WRITE !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
End DoDot:2
SET FBANS=""
QUIT
+64 IF FBANS=""
SET FBANS=FBHOLD
+65 IF FBANS?4N1"-"1.15N
Begin DoDot:2
+66 SET FBANS=$$UCLAIMNO^FBUTL135($GET(FBSITE),$GET(FBSRC),$GET(FBINT),$GET(FBCLT),FBANS)
End DoDot:2
+67 IF FBANS'?6N2UL4N1"-"1.15N
WRITE !!,"** INVALID CLAIM NUMBER ****",!!
SET FBANS=""
End DoDot:1
if FBTOUT
QUIT
IF FBANS'=""
SET FBCLAIMS=FBANS
QUIT
+68 ; flag not to save FPPS EDIT
IF FBTOUT
SET DTOUT=FBTOUT
SET FBXSTR=-1
QUIT
+69 IF $GET(FBCLAIMS)]""
Begin DoDot:1
+70 SET FBSTA=$EXTRACT(FBCLAIMS,1,5)
+71 SET FBSRC=$EXTRACT(FBCLAIMS,6)
+72 SET FBINT=$EXTRACT(FBCLAIMS,7)
+73 SET FBCLT=$$OCLMTYP^FBUTL135($EXTRACT(FBCLAIMS,8))
+74 SET $EXTRACT(FBCLAIMS,1,8)=""
+75 SET FBCLAIMS=$$PAYUCID^FBUTL135(FBPAT,FBVEND,FBTDTG,FBSERVSE,FBSTA,FBSRC,FBINT,FBCLT,FBCLAIMS)
+76 IF FBCLAIMS<1
SET FBCLAIMS=""
End DoDot:1
IF FBCLAIMS
QUIT
+77 ;
+78 NEW DA
+79 SET DA=$GET(FBSERVSE)
+80 SET DA(1)=$GET(FBTDTG)
+81 SET DA(2)=$GET(FBVEND)
+82 SET DA(3)=$GET(FBPAT)
+83 SET FBXSTR=$GET(FBXSTR)
+84 ; Restart edit
WRITE !!,"** INVALID CLAIM NUMBER *****",!!
DO EDITOUTP(FBXSTR,.DA)
+85 QUIT
OUTPHELP(DFN,FBV) ; ?? response
+1 ; gotta have a DFN, and a Vendor number
IF $GET(DFN)
IF $GET(FBV)
+2 IF '$TEST
QUIT 0
+3 NEW DTG,E7,E7TEXT,FBINT,FBIX,RETDIR,FBVENDT
+4 NEW DTOUT,DUOUT,DIRUT,DIROUT,X,Y,C
+5 NEW FBDOS,FBSVC,UCID,FBYEAR,OLINE,CNT,CLMID,CLMTYP
+6 SET FBTOUT=""
+7 SET E7TEXT("E")="1-EDI"
SET E7TEXT("S")="2-SCANNED"
SET E7TEXT("M")="3-MANUAL"
+8 SET (CNT,DTG)=0
SET RETDIR=""
SET C=","
+9 SET FBDOS=0
+10 ; date of service
FOR
SET FBDOS=$ORDER(^FBAAC(DFN,1,FBV,1,FBDOS))
SET FBSVC=0
if 'FBDOS
QUIT
Begin DoDot:1
+11 ; service provided
FOR
SET FBSVC=$ORDER(^FBAAC(DFN,1,FBV,1,FBDOS,1,FBSVC))
if 'FBSVC
QUIT
Begin DoDot:2
+12 SET UCID=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBDOS,1,FBSVC,5)),U,5)
+13 IF UCID=""
QUIT
+14 IF '$$VALIDATE^FBUTL135("O",UCID)
QUIT
+15 ; Quit if Initiation Type is "E"DI
IF $EXTRACT(UCID,7)="E"
QUIT
+16 SET CLMTYP=$EXTRACT(UCID,8)
+17 SET FBYEAR=$$FMTE^XLFDT(FBDOS)
SET FBVENDT=$$GET1^DIQ(162.02,FBDOS_C_FBV_C_DFN_C,.01,"I")
+18 ; Only want the YYYY-<xxxxx>
SET CLMID=$EXTRACT(UCID,9,28)
+19 SET OLINE=$EXTRACT(CLMID_" ",1,22)
+20 ; Vendor date
SET OLINE=OLINE_$EXTRACT(FBVENDT_" ",1,14)
+21 ; Full UCID
SET OLINE=OLINE_"("_UCID_")"
+22 SET UCID("LIST",9999999-FBVENDT,FBSVC,CLMID)=OLINE_"^^"_CLMTYP
End DoDot:2
End DoDot:1
+23 ;
+24 ; Nothing to display
IF '$DATA(UCID("LIST"))
WRITE !!,?5,"NO RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR"
QUIT ""
+25 IF '$TEST
WRITE !!,?4,"RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",!
+26 KILL OLINE
SET OLINE=$NAME(UCID("LIST"))
+27 ; Display list of prospects
+28 FOR CNT=1:1
SET OLINE=$QUERY(@OLINE)
if OLINE=""
QUIT
Begin DoDot:1
+29 IF '(CNT-1#5)
WRITE !," # CLAIM NO VEND INV DATE COMPLETE UCID"
+30 SET CNT(CNT)=$JUSTIFY(CNT,2)_": "_$PIECE(@OLINE,"^^")
SET CNT(CNT,"CLMID")=$QSUBSCRIPT(OLINE,4)_U_$PIECE(@OLINE,"^^",2)
WRITE !,CNT(CNT)
+31 IF '(CNT#5)
Begin DoDot:2
+32 NEW DA,DIR
+33 SET DIR(0)="NAO^1:"_CNT
SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
SET DIR("A")="CHOOSE 1-"_CNT_": "
DO ^DIR
+34 ;Possible options - X is a number = done. or X is null or X is "^"
+35 IF X?1.2N
SET RETDIR=X
QUIT
End DoDot:2
End DoDot:1
if RETDIR
QUIT
if $GET(DTOUT)
QUIT
if $GET(DUOUT)
QUIT
+36 IF '$GET(DTOUT)
IF '$GET(DUOUT)
+37 ; time out or opt out
IF '$TEST
SET RETDIR="-1^"_$GET(DTOUT)_"."_$GET(DUOUT)
KILL DTOUT,DUOUT
QUIT RETDIR
+38 ; no opt out, no time out
+39 ; user did not select any entries so far, so display final choice prompt
IF 'RETDIR
Begin DoDot:1
+40 NEW DA,DIR
+41 SET CNT=CNT-1
SET DIR(0)="NAO^1:"_CNT
SET DIR("A",1)="Press <RETURN> to return to main prompt, or"
SET DIR("A")="CHOOSE 1-"_CNT_":"
DO ^DIR
+42 IF X?1.2N
SET RETDIR=X
End DoDot:1
+43 IF '$GET(DTOUT)
IF '$GET(DUOUT)
+44 ; time out or opt out
IF '$TEST
SET RETDIR="-1^"_$GET(DTOUT)_"."_$GET(DUOUT)
KILL DTOUT,DUOUT
QUIT RETDIR
+45 ; quit with the selected claim
IF RETDIR
QUIT $GET(CNT(RETDIR,"CLMID"))
+46 QUIT RETDIR
+47 ;
+48 ;
+49 ;--------------------- INPATIENT ----------------------------------------
+50 ;
ENTINPAT(FBSTA,FBSRC,FBINT,FBCLT,FBCLAIMS,FBVEND) ;Returns UCID; FB*3.5*135
+1 ; Input: FBSTA = Station
+2 ; FBSRC = Source
+3 ; FBINT = Initiation Type
+4 ; FBCLT = Claim Type
+5 ; FBCLAIMS = FPPS CLAIM ID - replaces sequence number
+6 ; FBVEND = Vendor IEN
+7 ;
+8 ; Output: UCID
+9 ;
+10 NEW FBRETVAL,FBTOUT,FBANS
+11 KILL DTOUT
+12 SET FBSTA=$GET(FBSTA)
SET FBSRC=$GET(FBSRC)
SET FBINT=$GET(FBINT)
SET FBCLT=$GET(FBCLT)
SET FBCLAIMS=$GET(FBCLAIMS)
SET FBVEND=$GET(FBVEND)
SET (FBRETVAL,FBTOUT,FBUOUT,FBANS)=""
+13 IF FBCLAIMS="N/A"
SET FBCLAIMS=""
+14 IF FBCLAIMS]""
Begin DoDot:1
+15 SET FBCLAIMS=+$PIECE($$HTE^XLFDT($HOROLOG)," ",3)_"-"_FBCLAIMS
+16 SET FBCLAIMS=$$UCLAIMNO^FBUTL135(FBSTA,FBSRC,"E",FBCLT,FBCLAIMS)
End DoDot:1
QUIT FBCLAIMS
+17 FOR
READ !,"CLAIM NUMBER: ",FBANS:DTIME
SET FBTOUT='$TEST
if FBTOUT
QUIT
Begin DoDot:1
+18 IF $TRANSLATE(FBANS,"new","NEW")="NEW"
SET FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$GET(FBSRC),"M",$GET(FBCLT))
WRITE "#: "_$EXTRACT(FBANS,9,28)
QUIT
+19 IF FBANS="??"
SET FBANS=$$ENTHELP(FBVEND,.FBTOUT,.FBUOUT)
if FBUOUT
SET (FBANS,FBUOUT)=""
if FBANS=""
QUIT
+20 IF $EXTRACT(FBANS)="^"
SET FBANS=""
WRITE !!,"This is a required response. ""^"" is not allowed.",!
QUIT
+21 IF FBANS="?"
Begin DoDot:2
+22 WRITE !!,"Enter ""NEW"" to automatically generate a new claim number,"
+23 WRITE !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
+24 WRITE !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
End DoDot:2
SET FBANS=""
QUIT
+25 IF FBANS=""
WRITE !!," REQUIRED ENTRY.",!
QUIT
+26 IF FBANS?4N1"-"1.15N
SET FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$GET(FBSRC),$GET(FBINT),$GET(FBCLT),FBANS)
+27 IF FBANS'?6N2UL4N1"-"1.15N
WRITE !!,"*** INVALID CLAIM NUMBER ***",!!
SET FBANS=""
End DoDot:1
if FBTOUT
QUIT
IF FBANS'=""
SET FBCLAIMS=FBANS
QUIT
+28 IF 'FBTOUT
IF 'FBUOUT
QUIT FBCLAIMS
+29 IF FBTOUT
SET DTOUT=FBTOUT
+30 IF FBUOUT
SET DUOUT=FBUOUT
+31 QUIT ""
+32 ;
ENTHELP(FBVEND,FBTOUT,FBUOUT) ; Help for UCID in "FBCH ENTER PAYMENT" ; FB*3.5*135
+1 ; gotta have a DFN, and a Vendor number
IF $GET(DFN)
IF $GET(FBVEND)
+2 IF '$TEST
QUIT 0
+3 NEW CLMID,CNT,DTG,E7,E7TEXT,FBINT,FBIX,OLINE,RETDIR,UCIDLIST,YR
+4 NEW DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+5 SET (FBTOUT,FBUOUT)=""
+6 SET E7TEXT("E")="1-EDI"
SET E7TEXT("S")="2-SCANNED"
SET E7TEXT("M")="3-MANUAL"
+7 SET (CNT,DTG)=0
SET RETDIR=""
+8 ; Build list of prospects
+9 FOR
SET DTG=$ORDER(^FBAAI("AG",DFN,DTG))
SET FBIX=0
if 'DTG
QUIT
Begin DoDot:1
+10 FOR
SET FBIX=$ORDER(^FBAAI("AG",DFN,DTG,FBIX))
if 'FBIX
QUIT
Begin DoDot:2
+11 KILL FBINT
DO GETS^DIQ(162.5,FBIX,"2;46;85","IE","FBINT")
+12 ; Quit if vendor doesn't match
IF FBINT("162.5",FBIX_",",2,"I")'=FBVEND
QUIT
+13 ; Quit if no UCID
IF FBINT("162.5",FBIX_",",85,"E")=""
QUIT
+14 ; Quit if Initiation Type is "E"DI
IF $EXTRACT(FBINT("162.5",FBIX_",",85,"E"),7)="E"
QUIT
+15 ; Quit if not valid
IF '$$VALIDATE^FBUTL135("I",FBINT("162.5",FBIX_",",85,"E"))
QUIT
+16 KILL OLINE
MERGE OLINE=FBINT("162.5",FBIX_",")
+17 SET UCIDLIST=FBINT("162.5",FBIX_",",85,"E")
+18 SET YR=(9999999.999999-$GET(OLINE(46,"I")))
SET CLMID=$PIECE(UCIDLIST,"-",1,2)
SET E7=$EXTRACT(UCIDLIST,7)
+19 IF $DATA(E7TEXT(E7))
SET E7=E7TEXT(E7)
+20 IF '$TEST
SET E7="4-"_E7
+21 ; Only want the YYYY-<xxxxx>
SET OLINE=$EXTRACT($GET(OLINE(85,"E"))_" ",9,30)
+22 ; Vendor date
SET OLINE=OLINE_$EXTRACT($GET(OLINE(46,"E"))_" ",1,14)
+23 ; Full UCID
SET OLINE=OLINE_"("_$GET(OLINE(85,"E"))_")"
+24 SET UCIDLIST("LIST",YR,E7,CLMID,FBIX)=OLINE
End DoDot:2
End DoDot:1
+25 KILL OLINE
SET OLINE=$NAME(UCIDLIST("LIST"))
+26 ; Nothing to display
IF '$DATA(UCIDLIST("LIST"))
WRITE !!,?5,"NO RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",!
QUIT ""
+27 IF '$TEST
WRITE !!,?4,"RECENT CLAIM NUMBERS FOR THIS PATIENT/VENDOR",!
+28 ; Display list of prospects
+29 FOR CNT=1:1
SET OLINE=$QUERY(@OLINE)
if OLINE=""
QUIT
Begin DoDot:1
+30 IF '(CNT-1#5)
WRITE !," # CLAIM NO VEND INV DATE COMPLETE UCID"
+31 SET CNT(CNT)=$JUSTIFY(CNT,2)_": "_@OLINE
SET CNT(CNT,"CLMID")=$QSUBSCRIPT(OLINE,4)_U_$QSUBSCRIPT(OLINE,3)
WRITE !,CNT(CNT)
+32 IF '(CNT#5)
Begin DoDot:2
+33 NEW DA,DIR
+34 SET DIR(0)="NAO^1:"_CNT
SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
SET DIR("A")="CHOOSE 1-"_CNT_": "
DO ^DIR
+35 ;Possible options - X is a number = done. or X is null or X is "^"
+36 IF X?1.2N
SET RETDIR=X
QUIT
End DoDot:2
End DoDot:1
if RETDIR
QUIT
if $GET(DTOUT)
QUIT
if $GET(DUOUT)
QUIT
+37 SET FBTOUT=$GET(DTOUT)
SET FBUOUT=$GET(DUOUT)
+38 IF 'FBTOUT
IF 'FBUOUT
+39 ; time out or opt out
IF '$TEST
QUIT ""
+40 ; no opt out, no time out
+41 ; user did not select any entries so far, so display final choice prompt
IF 'RETDIR
Begin DoDot:1
+42 NEW DA,DIR
+43 SET CNT=CNT-1
SET DIR(0)="NAO^1:"_CNT
SET DIR("A",1)="Press <RETURN> to return to main prompt, or"
SET DIR("A")="CHOOSE 1-"_CNT_":"
DO ^DIR
+44 IF X?1.2N
SET RETDIR=X
End DoDot:1
+45 SET FBTOUT=$GET(DTOUT)
SET FBUOUT=$GET(DUOUT)
+46 IF 'FBTOUT
IF 'FBUOUT
+47 ; time out or opt out
IF '$TEST
QUIT ""
+48 ; quit with the selected claim
IF RETDIR
QUIT $PIECE($GET(CNT(RETDIR,"CLMID")),U)
+49 QUIT RETDIR
+50 ;
EDINPAT(FBXSTR,FBI) ; EDIT UNIQUE CLAIM ID for FEE BASIS INVOICE file - 162.5
+1 ; Input: FBXSTR = FPPS value entered by user for FPPS
+2 ; FBI = IEN of Invoice record
+3 ;
+4 ; Output: UCID
+5 ;
+6 NEW FBDATA,FBFPPSCL,FBICLAIM,FBSITE,FBSTA,FBSRC,FBINT,FBCLT,FPPSCLM,FBCLAIMS,FBPRMPT,FBHOLD,FBVEND
+7 SET FBXSTR=$GET(FBXSTR)
SET FBI=$GET(FBI)
SET FBSTA=$$STATION^FBUTL135
SET FBVEND=$$GET1^DIQ(162.5,FBI_",",2,"I")
SET FPPSCLM=$$GET1^DIQ(162.5,FBI_",",56,"I")
SET (FBHOLD,FBICLAIM)=""
+8 IF FBXSTR'=-1
IF FBI
+9 IF '$TEST
QUIT
+10 ;
+11 ; If user entered FPPS, create UCID, save, and quit
IF FBXSTR]""
Begin DoDot:1
+12 SET FBICLAIM=+$PIECE($$HTE^XLFDT($HOROLOG)," ",3)_"-"_FBXSTR
+13 ; Populate UCID field
SET FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSTA,1,"E",FBICLAIM)
End DoDot:1
QUIT
+14 ;
+15 ; If user didn't enter a new FPPS CLAIM ID
+16 IF FBXSTR=""
Begin DoDot:1
+17 ;If FPPS CLAIM ID field is populated, clear out exisitng UCID and prepare for new one
+18 IF FPPSCLM]""
SET FBICLAIM(162.5,FBI_",",85)=""
DO FILE^DIE(,"FBICLAIM")
KILL FBICLAIM
SET FBICLAIM=""
QUIT
+19 ;FPPS CLAIM ID field is null get existing UCID for default
+20 ; if not a manual claim, don't use it
SET FBICLAIM=$$GET1^DIQ(162.5,FBI_",",85,"I")
IF $EXTRACT(FBICLAIM,7)'="M"
SET FBICLAIM=""
End DoDot:1
+21 ;
+22 ; If UCID not populated
IF FBICLAIM=""
Begin DoDot:1
+23 ; allow user to enter new UCID
SET FBICLAIM=$$ENTINPAT(,1,"M","I",,FBVEND)
+24 IF '$GET(DTOUT)
IF '$GET(DUOUT)
IF FBICLAIM]""
Begin DoDot:2
+25 SET FBSITE=$EXTRACT(FBICLAIM,1,5)
+26 SET FBSRC=$EXTRACT(FBICLAIM,6)
+27 SET FBINT=$EXTRACT(FBICLAIM,7)
+28 SET $EXTRACT(FBICLAIM,1,8)=""
+29 ; Populate UCID field
SET FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSITE,FBSRC,FBINT,FBICLAIM)
End DoDot:2
End DoDot:1
QUIT
+30 ; we have an existing UCID - validate it then allow edit
+31 ;
+32 ; not valid -
IF '$$VALIDATE^FBUTL135("I",FBICLAIM)
SET FBICLAIM=""
+33 IF '$TEST
Begin DoDot:1
+34 SET FBSITE=$EXTRACT(FBICLAIM,1,5)
IF FBSITE=""
SET FBSITE=FBSTA
+35 SET FBSRC=$EXTRACT(FBICLAIM,6)
IF FBSRC=""
SET FBSRC=1
+36 SET FBINT=$EXTRACT(FBICLAIM,7)
IF FBINT=""
SET FBINT="M"
+37 SET FBCLT="I"
+38 SET $EXTRACT(FBICLAIM,1,8)=""
SET FBHOLD=FBICLAIM
End DoDot:1
+39 ;
+40 IF FBICLAIM]""
SET FBPRMPT=" "_FBICLAIM_" //"
+41 SET FBPRMPT="CLAIM NUMBER:"_$GET(FBPRMPT)_" "
SET (FBTOUT,FBUOUT)=""
+42 FOR
WRITE !,FBPRMPT
READ FBANS:DTIME
SET FBTOUT='$TEST
if FBTOUT
QUIT
Begin DoDot:1
+43 ; accept existing UCID suffix
IF FBANS=""
IF 'FBTOUT
IF FBICLAIM]""
SET FBANS=FBICLAIM
QUIT
+44 IF $TRANSLATE(FBANS,"new","NEW")="NEW"
SET FBANS=$$UCLAIMNO^FBUTL135(FBSTA,$GET(FBSRC),$GET(FBINT),$GET(FBCLT))
WRITE "#: "_$EXTRACT(FBANS,9,28)
QUIT
+45 IF FBANS="??"
Begin DoDot:2
+46 SET FBANS=$$ENTHELP(FBVEND,.FBTOUT,.FBUOUT)
+47 IF FBTOUT
SET (FBTOUT,FBANS)=""
QUIT
+48 IF FBUOUT
QUIT
+49 IF FBANS=""
QUIT
End DoDot:2
if FBANS=""
QUIT
+50 IF FBANS="@"
WRITE !!," REQUIRED ENTRY.",!
SET FBANS=""
QUIT
+51 IF $EXTRACT(FBANS)="^"
SET FBANS=""
WRITE !!,"This is a required response. ""^"" is not allowed.",!
QUIT
+52 IF FBANS="?"
Begin DoDot:2
+53 WRITE !!,"Enter ""NEW"" to automatically generate a new claim number,"
+54 WRITE !,"or enter an existing numeric claim number in format YYYY-<nn..>,"
+55 WRITE !,"or enter ?? to see a list of existing claim numbers for this vendor.",!
End DoDot:2
SET FBANS=""
QUIT
+56 IF FBANS=""
SET FBANS=FBHOLD
QUIT
+57 IF FBANS?4N1"-"1.15N
SET FBANS=$$UCLAIMNO^FBUTL135($GET(FBSITE),$GET(FBSRC),$GET(FBINT),$GET(FBCLT),FBANS)
+58 IF FBANS'?6N2UL4N1"-"1.15N
WRITE !!,"*** INVALID CLAIM NUMBER ****",!!
SET FBANS=""
QUIT
End DoDot:1
if FBTOUT
QUIT
if FBUOUT
QUIT
IF FBANS'=""
SET FBCLAIMS=FBANS
QUIT
+59 ; flag not to save FPPS EDIT
IF FBTOUT
SET DTOUT=FBTOUT
SET FBX=-1
+60 ; flag not to save FPPS EDIT
IF FBUOUT
SET DUOUT=FBUOUT
SET FBX=-1
+61 IF 'FBTOUT
IF 'FBUOUT
Begin DoDot:1
+62 IF FBANS?4N1"-"1.15N
Begin DoDot:2
+63 SET FBANS=FBSTA_"1MI"_FBANS
End DoDot:2
+64 SET FBSTA=$EXTRACT(FBANS,1,5)
+65 SET FBSRC=$EXTRACT(FBANS,6)
+66 SET FBINT=$EXTRACT(FBANS,7)
+67 SET $EXTRACT(FBANS,1,8)=""
+68 SET FBICLAIM=$$INVUCID^FBUTL135(FBI,FBSTA,FBSRC,FBINT,FBANS)
+69 ; Populate UCID field
IF +FBICLAIM=-1
WRITE !!,"*** INVALID CLAIM NUMBER *****",!!
DO EDINPAT(FBXSTR,FBI)
End DoDot:1
+70 QUIT
