- 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 Feb 18, 2025@23:27:08 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