- FBAACO2 ;AISC/GRR - PAYMENT PROCESS FOR DUPLICATE ;12/19/2014
- ;;3.5;FEE BASIS;**4,55,61,77,116,122,133,108,135,139,123,157,158**;JAN 30, 1995;Build 94
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;FB*3.5*157 Modify file 162, Diagnosis (field 28) stuff from '///' to '////'
- ; since needed file 80 dx IEN is already passed back from DX
- ; lookup.
- ;
- RD S DIR(0)="Y",DIR("A")="Want this payment stored as a Medical Denial",DIR("B")="YES",DIR("?")="Enter 'Yes' to store payment entry as a denial and send a Suspension letter. Enter 'No' to have nothing happen." D ^DIR K DIR Q:$D(DIRUT)!('Y)
- S FBDEN=1 Q
- FILE ;files sp multiple entry
- K DR S TP="" I $G(FBDEN) S FBAMTPD=0
- ; FB*3.5*123 - set IPAC fields .05 and .055 on the next line
- S DR="49///^S X=$G(FBCSID);50///^S X=$G(FBFPPSC);81///^S X=$G(FBUCI135);.05////^S X=$G(FBIA);.055///^S X=$G(FBDODINV);I $G(FBDEN) S Y=1;48;47//1;S FBUNITS=X;S:$G(FBFPPSC)="""" Y=""@11"";S FBX=$$FPPSL^FBUTL5();S:FBX=-1 Y=0;51///^S X=FBX;@11"
- ; fb*3.5*116 do not enable different interest indicator values at line item level; interest indicator set at invoice level
- ;FB*3.5*158 store payment methodology using fee schedule code
- S DR(1,162.03,1)="34///^S X=$G(FBAAMM);D POS^FBAACO1;S:'$G(FBHCFA(30)) Y=0;1;S J=X;I $G(FBDEN) S Y=2;D FEE^FBAACO0;44////^S X=FBFSAMT;45///^S X=FBFSUSD;2///^S X=FBAMTPD;S K=X;82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)"
- S DR(1,162.03,2)="S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,5,,,,.FBRRMK,1);S:FBX=0 Y=0;6////^S X=DUZ"
- S DR(1,162.03,3)="7////^S X=FBAABE;8////^S X=BO;13///^S X=FBAAID;14///^S X=FBAAIN;33///^S X=FBAAVID;I $G(FBDEN) S FBTST=1"
- I '$G(FBDEN) D
- . ; FB*3.5*139-JLG/JAS-ICD10 REMEDIATION - Made modifications to DR strings for ICD-10, added FBDXCHK1 and FBDXCHK2 for this
- .N FBCSVSTR S FBCSVSTR="I X]"""" S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@30"";"
- .N FBDXCHK1 S FBDXCHK1=";@20;S XX1=-1 S XX1=$$FBDXCHK^FBAACO2(FBAADT) S:XX1<0 Y=""@20"";28////^S X=XX1;S Y=""@6"";" ;FB*3.5*157
- .N FBDXCHK2 S FBDXCHK2=";@25;S XX1=-1 S XX1=$$FBDXCHK^FBAACO2(FBAADT) S:XX1<0 Y=""@25"";28////^S X=XX1;S Y=""@35"";@30;" ;FB*3.5*157
- .S DR(1,162.03,4)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y=""@1"";S:FB7078]""""!($D(FB583)) Y=30"_FBDXCHK1_"@6;30////^S X=FBHCFA(30);"
- .S DR(1,162.03,5)="31;32R;S Y=15;@1"_FBDXCHK2_FBCSVSTR_"@35;30////^S X=FBHCFA(30);31;15///^S X=FBPT;"
- . ;end 139
- .S DR(1,162.03,6)="16////^S X=FBPOV;17///^S X=FBTT;18///^S X=FBAAPTC;23////^S X=FBTYPE;26////^S X=FBPSA;S:$D(FBV583) Y=""@2"";27////^S X=FB7078;S Y=""@99"";@2;27////^S X=FBV583;@99;S FBTST=1;54////^S X=FBCNTRP"
- .S DR(1,162.03,7)="73;74;75;58;59;60;61;62;63;64;65;66;67;76;77;78;79;68;69" ;FB*3.5*122 Line Item Provider information ;FB*3.5*133 Provider Information
- S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
- S DA(3)=DFN,DA(2)=FBV,DA(1)=FBSDI,DA=FBAACPI
- D LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",FBAACPI,1)
- D
- . N ICDVDT S ICDVDT=$G(FBAADT) D ^DIE
- I '$D(DTOUT),$G(FBTST) D
- . D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
- . D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
- . K FBADJ,FBRRMK ;must kill so codes don't persist into next procedure/line
- L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
- I $D(DTOUT) D KILL Q
- I '$G(FBTST),$G(DA) S DIR(0)="YA",DIR("A")="Entering an '^' will delete "_$S($G(FBDEN):"denial",1:"payment")_". Are you sure you want to delete? ",DIR("B")="No" D ^DIR K DIR G FILE:'$D(DIRUT)&('Y) D KILL Q
- K FBTST,FBDEN,DIE,DR,DA,FBX
- I $D(FBDL) S FBAAOUT=1 Q
- Q
- ;
- FBDXCHK(FBAADT) ;DEM;139 Call to ASF if ICD-10.
- ;
- ; This call checks if the payment diagnosis date to
- ; determine if diagnosis code is ICD-9 or ICD-10.
- ; If ICD-9, then call ICD-9 code enhanced for inactive code checks.
- ; Else, call Advanced Search Functionality (ASF).
- ; If user enters "^" to exit, then quit and send calling
- ; routine 999 for exit.
- ;
- ; If no ICD-10 data found, then send calling routine -1
- ; to indicate no data found.
- ; If data found, then stuff diagnosis into ICD DIAGNOSIS
- ; field, and quit and send the calling routine 10 for ICD-10 code.
- ;
- ; Input:
- ; FBAADT = Date of Interest for FB payments.
- ;
- ; Output:
- ; FB9 = ICD-9 diagnosis
- ; FB99 = User entered "^" to exit payment edit.
- ; -1 = No ICD-10 data found
- ; FB10 = ICD-10 diagnosis
- ;
- N ICDSYS,IMPDATE,XX1
- S ICDSYS=10,IMPDATE=$$IMPDATE^LEXU("10D")
- S:FBAADT<IMPDATE ICDSYS=9
- S XX1=-1
- I ICDSYS=9 S XX1=$$ASKICD9^FBAACO2(FBAADT) Q XX1 ;ICD-9
- S XX1=$$ASKICD10^FBAACO2(FBAADT) Q XX1 ;ICD-10 IEN CODE
- ;
- ; retrieves existing value in db if exists and prompts user for ICD-9 primary diagnosis
- ASKICD9(INDT,FBFREQ) ;FB*3.5*139-JAS-ICD10 REMEDIATION
- N DPRMPT,FBDX
- S EDATE=INDT ; edate is the date of interest for ICD10 diagnosis code lookup
- I $G(FBFREQ)="" S FBFREQ="N" ; force field to be required flag
- N FBDXIEN
- S DPRMPT="PRIMARY DIAGNOSIS"
- S FBDXIEN=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0)),U,23) ; retrieve existing DX ien
- ;S:FBDXIEN>0 DPRMPT=DPRMPT_": "_$$ICD9^FBCSV1(FBDXIEN,EDATE)_"// " ;obtain current diagnosis and set as default
- S FBDX=-1 S FBDX=$$ENICD9^FBICD9(EDATE,DPRMPT,"Y","","Y",FBDXIEN)
- I FBDXIEN>0,FBDX=-1 S FBDX=FBDXIEN W $$ICD9^FBCSV1(FBDXIEN,EDATE) ; return default value if spaces entered
- K EDATE,INDT
- S FBDX=+FBDX
- Q FBDX
- ;
- ; retrieves existing value in db if exists and prompts user for ICD-10 primary diagnosis
- ASKICD10(INDT,FBFREQ) ;FB*3.5*139-JLG-ICD10 REMEDIATION
- N DP,DPRMPT,FBDCDA,FBDX
- S EDATE=INDT ; edate is the date of interest for ICD10 diagnosis code lookup
- I $G(FBFREQ)="" S FBFREQ="N" ; force field to be required flag
- S DP=162.03 ; file number used to check if diagnosis field is required
- S FBDCDA=DA ; DA equals FBAACPI
- N FBDXIEN
- S DPRMPT="PRIMARY DIAGNOSIS"
- S FBDXIEN=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0)),U,23) ; retrieve existing DX ien
- S:FBDXIEN>0 DPRMPT=DPRMPT_": "_$$ICD9^FBCSV1(FBDXIEN,EDATE)_"// " ;obtain current diagnosis and set as default
- S FBDX=-1 S FBDX=$$ASKICD10^FBASF(DPRMPT,"","","",FBFREQ) ; returns -1 or ien of icd10 diagnosis code
- I FBDXIEN>0,FBDX=-1 S FBDX=FBDXIEN W $$ICD9^FBCSV1(FBDXIEN,EDATE) ; return default value if spaces entered
- K EDATE,INDT
- Q FBDX
- ;
- KILL S DIK=DIE D ^DIK K DIE,DIK I '$G(FBCNP) D Q^FBAACO S FBAAOUT=1
- W !,"Deleted" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACO2 6377 printed Feb 18, 2025@23:21:36 Page 2
- FBAACO2 ;AISC/GRR - PAYMENT PROCESS FOR DUPLICATE ;12/19/2014
- +1 ;;3.5;FEE BASIS;**4,55,61,77,116,122,133,108,135,139,123,157,158**;JAN 30, 1995;Build 94
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;FB*3.5*157 Modify file 162, Diagnosis (field 28) stuff from '///' to '////'
- +5 ; since needed file 80 dx IEN is already passed back from DX
- +6 ; lookup.
- +7 ;
- RD SET DIR(0)="Y"
- SET DIR("A")="Want this payment stored as a Medical Denial"
- SET DIR("B")="YES"
- SET DIR("?")="Enter 'Yes' to store payment entry as a denial and send a Suspension letter. Enter 'No' to have nothing happen."
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!('Y)
- QUIT
- +1 SET FBDEN=1
- QUIT
- FILE ;files sp multiple entry
- +1 KILL DR
- SET TP=""
- IF $GET(FBDEN)
- SET FBAMTPD=0
- +2 ; FB*3.5*123 - set IPAC fields .05 and .055 on the next line
- +3 SET DR="49///^S X=$G(FBCSID);50///^S X=$G(FBFPPSC);81///^S X=$G(FBUCI135);.05////^S X=$G(FBIA);.055///^S X=$G(FBDODINV);I $G(FBDEN) S Y=1;48;47//1;S FBUNITS=X;S:$G(FBFPPSC)="""" Y=""@11"";S FBX=$$FPPSL^FBUTL5();S:FBX=-1 Y=0;51///^S X=FBX;@11"
- +4 ; fb*3.5*116 do not enable different interest indicator values at line item level; interest indicator set at invoice level
- +5 ;FB*3.5*158 store payment methodology using fee schedule code
- +6 SET DR(1,162.03,1)="34///^S X=$G(FBAAMM);D POS^FBAACO1;S:'$G(FBHCFA(30)) Y=0;1;S J=X;I $G(FBDEN) S Y=2;D FEE^FBAACO0;44////^S X=FBFSAMT;45///^S X=FBFSUSD;2///^S X=FBAMTPD;S K=X;82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)"
- +7 SET DR(1,162.03,2)="S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,5,,,,.FBRRMK,1);S:FBX=0 Y=0;6////^S X=DUZ"
- +8 SET DR(1,162.03,3)="7////^S X=FBAABE;8////^S X=BO;13///^S X=FBAAID;14///^S X=FBAAIN;33///^S X=FBAAVID;I $G(FBDEN) S FBTST=1"
- +9 IF '$GET(FBDEN)
- Begin DoDot:1
- +10 ; FB*3.5*139-JLG/JAS-ICD10 REMEDIATION - Made modifications to DR strings for ICD-10, added FBDXCHK1 and FBDXCHK2 for this
- +11 NEW FBCSVSTR
- SET FBCSVSTR="I X]"""" S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@30"";"
- +12 ;FB*3.5*157
- NEW FBDXCHK1
- SET FBDXCHK1=";@20;S XX1=-1 S XX1=$$FBDXCHK^FBAACO2(FBAADT) S:XX1<0 Y=""@20"";28////^S X=XX1;S Y=""@6"";"
- +13 ;FB*3.5*157
- NEW FBDXCHK2
- SET FBDXCHK2=";@25;S XX1=-1 S XX1=$$FBDXCHK^FBAACO2(FBAADT) S:XX1<0 Y=""@25"";28////^S X=XX1;S Y=""@35"";@30;"
- +14 SET DR(1,162.03,4)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y=""@1"";S:FB7078]""""!($D(FB583)) Y=30"_FBDXCHK1_"@6;30////^S X=FBHCFA(30);"
- +15 SET DR(1,162.03,5)="31;32R;S Y=15;@1"_FBDXCHK2_FBCSVSTR_"@35;30////^S X=FBHCFA(30);31;15///^S X=FBPT;"
- +16 ;end 139
- +17 SET DR(1,162.03,6)="16////^S X=FBPOV;17///^S X=FBTT;18///^S X=FBAAPTC;23////^S X=FBTYPE;26////^S X=FBPSA;S:$D(FBV583) Y=""@2"";27////^S X=FB7078;S Y=""@99"";@2;27////^S X=FBV583;@99;S FBTST=1;54////^S X=FBCNTRP"
- +18 ;FB*3.5*122 Line Item Provider information ;FB*3.5*133 Provider Information
- SET DR(1,162.03,7)="73;74;75;58;59;60;61;62;63;64;65;66;67;76;77;78;79;68;69"
- End DoDot:1
- +19 SET DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
- +20 SET DA(3)=DFN
- SET DA(2)=FBV
- SET DA(1)=FBSDI
- SET DA=FBAACPI
- +21 DO LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",FBAACPI,1)
- +22 Begin DoDot:1
- +23 NEW ICDVDT
- SET ICDVDT=$GET(FBAADT)
- DO ^DIE
- End DoDot:1
- +24 IF '$DATA(DTOUT)
- IF $GET(FBTST)
- Begin DoDot:1
- +25 DO FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
- +26 DO FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
- +27 ;must kill so codes don't persist into next procedure/line
- KILL FBADJ,FBRRMK
- End DoDot:1
- +28 LOCK -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
- +29 IF $DATA(DTOUT)
- DO KILL
- QUIT
- +30 IF '$GET(FBTST)
- IF $GET(DA)
- SET DIR(0)="YA"
- SET DIR("A")="Entering an '^' will delete "_$SELECT($GET(FBDEN):"denial",1:"payment")_". Are you sure you want to delete? "
- SET DIR("B")="No"
- DO ^DIR
- KILL DIR
- if '$DATA(DIRUT)&('Y)
- GOTO FILE
- DO KILL
- QUIT
- +31 KILL FBTST,FBDEN,DIE,DR,DA,FBX
- +32 IF $DATA(FBDL)
- SET FBAAOUT=1
- QUIT
- +33 QUIT
- +34 ;
- FBDXCHK(FBAADT) ;DEM;139 Call to ASF if ICD-10.
- +1 ;
- +2 ; This call checks if the payment diagnosis date to
- +3 ; determine if diagnosis code is ICD-9 or ICD-10.
- +4 ; If ICD-9, then call ICD-9 code enhanced for inactive code checks.
- +5 ; Else, call Advanced Search Functionality (ASF).
- +6 ; If user enters "^" to exit, then quit and send calling
- +7 ; routine 999 for exit.
- +8 ;
- +9 ; If no ICD-10 data found, then send calling routine -1
- +10 ; to indicate no data found.
- +11 ; If data found, then stuff diagnosis into ICD DIAGNOSIS
- +12 ; field, and quit and send the calling routine 10 for ICD-10 code.
- +13 ;
- +14 ; Input:
- +15 ; FBAADT = Date of Interest for FB payments.
- +16 ;
- +17 ; Output:
- +18 ; FB9 = ICD-9 diagnosis
- +19 ; FB99 = User entered "^" to exit payment edit.
- +20 ; -1 = No ICD-10 data found
- +21 ; FB10 = ICD-10 diagnosis
- +22 ;
- +23 NEW ICDSYS,IMPDATE,XX1
- +24 SET ICDSYS=10
- SET IMPDATE=$$IMPDATE^LEXU("10D")
- +25 if FBAADT<IMPDATE
- SET ICDSYS=9
- +26 SET XX1=-1
- +27 ;ICD-9
- IF ICDSYS=9
- SET XX1=$$ASKICD9^FBAACO2(FBAADT)
- QUIT XX1
- +28 ;ICD-10 IEN CODE
- SET XX1=$$ASKICD10^FBAACO2(FBAADT)
- QUIT XX1
- +29 ;
- +30 ; retrieves existing value in db if exists and prompts user for ICD-9 primary diagnosis
- ASKICD9(INDT,FBFREQ) ;FB*3.5*139-JAS-ICD10 REMEDIATION
- +1 NEW DPRMPT,FBDX
- +2 ; edate is the date of interest for ICD10 diagnosis code lookup
- SET EDATE=INDT
- +3 ; force field to be required flag
- IF $GET(FBFREQ)=""
- SET FBFREQ="N"
- +4 NEW FBDXIEN
- +5 SET DPRMPT="PRIMARY DIAGNOSIS"
- +6 ; retrieve existing DX ien
- SET FBDXIEN=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0)),U,23)
- +7 ;S:FBDXIEN>0 DPRMPT=DPRMPT_": "_$$ICD9^FBCSV1(FBDXIEN,EDATE)_"// " ;obtain current diagnosis and set as default
- +8 SET FBDX=-1
- SET FBDX=$$ENICD9^FBICD9(EDATE,DPRMPT,"Y","","Y",FBDXIEN)
- +9 ; return default value if spaces entered
- IF FBDXIEN>0
- IF FBDX=-1
- SET FBDX=FBDXIEN
- WRITE $$ICD9^FBCSV1(FBDXIEN,EDATE)
- +10 KILL EDATE,INDT
- +11 SET FBDX=+FBDX
- +12 QUIT FBDX
- +13 ;
- +14 ; retrieves existing value in db if exists and prompts user for ICD-10 primary diagnosis
- ASKICD10(INDT,FBFREQ) ;FB*3.5*139-JLG-ICD10 REMEDIATION
- +1 NEW DP,DPRMPT,FBDCDA,FBDX
- +2 ; edate is the date of interest for ICD10 diagnosis code lookup
- SET EDATE=INDT
- +3 ; force field to be required flag
- IF $GET(FBFREQ)=""
- SET FBFREQ="N"
- +4 ; file number used to check if diagnosis field is required
- SET DP=162.03
- +5 ; DA equals FBAACPI
- SET FBDCDA=DA
- +6 NEW FBDXIEN
- +7 SET DPRMPT="PRIMARY DIAGNOSIS"
- +8 ; retrieve existing DX ien
- SET FBDXIEN=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0)),U,23)
- +9 ;obtain current diagnosis and set as default
- if FBDXIEN>0
- SET DPRMPT=DPRMPT_": "_$$ICD9^FBCSV1(FBDXIEN,EDATE)_"// "
- +10 ; returns -1 or ien of icd10 diagnosis code
- SET FBDX=-1
- SET FBDX=$$ASKICD10^FBASF(DPRMPT,"","","",FBFREQ)
- +11 ; return default value if spaces entered
- IF FBDXIEN>0
- IF FBDX=-1
- SET FBDX=FBDXIEN
- WRITE $$ICD9^FBCSV1(FBDXIEN,EDATE)
- +12 KILL EDATE,INDT
- +13 QUIT FBDX
- +14 ;
- KILL SET DIK=DIE
- DO ^DIK
- KILL DIE,DIK
- IF '$GET(FBCNP)
- DO Q^FBAACO
- SET FBAAOUT=1
- +1 WRITE !,"Deleted"
- QUIT