Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBAAMP1

FBAAMP1.m

Go to the documentation of this file. 
  1. FBAAMP1 ;AISC/CMR - MULTIPLE PAYMENT ENTRY ;7/6/2003
  1.  ;;3.5;FEE BASIS;**4,55,61,77,139,158**;JAN 30, 1995;Build 94
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1. SUSP ;enter suspense data
  1.  N FBX
  1.  ;S DIR(0)="162.5,9",DIR("A")="Amount Suspended: $",DIR("B")=FBJ-FBK,DIR("?")="Press Return if $ "_(FBJ-FBK)_" is Amount Suspended, otherwise enter correct suspension amount" D ^DIR K DIR
  1.  ;I $D(DIRUT) W !!,"Invalid entry, enter a number between .01 and 999999" G SUSP
  1.  ;S FBAAAS=+Y
  1.  ;I +Y'=(FBJ-FBK) S FBAAAS=+Y W ! S DIR("A")="Is $"_FBAAAS_" correct for Amount Suspended",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
  1.  ;G SUSP:'Y
  1.  ;W !! S DIC="^FBAA(161.27,",DIC(0)="AEQ" D ^DIC I X["^" S FBAAOUT=1 Q
  1.  ;S FBAASC=+Y
  1.  S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,5,,,,.FBRRMK,1)
  1.  I FBX=0 S FBAAOUT=1
  1.  Q
  1. SUSP1 I FBAASC=4 K ^TMP($J,"FBWP") W !!,"Suspension Description: " S DIC="^TMP($J,""FBWP"",",DWLW=80,DWPK=1 D EN^DIWE K DIC,DWLW,DWPK I '$O(^TMP($J,"FBWP",0)) W !!,*7,"Description of Suspense is required." G SUSP1
  1.  Q
  1. HCFA N ICDMDE S ICDMDE=10
  1.  I FBMPDT<$$IMPDATE^LEXU("10D") S ICDMDE=9 N XX1 ;FB*3.5*139-JLG-ICD10 REMEDIATION
  1.  F FBSI=28,30,31,32 S FBHCFA(FBSI)=""
  1.  W ! F FBSI=28,30,31 D  Q:$G(FBAAOUT)
  1.  . ;DEM/JLG/JAS FB*3.5*139-JLG-ICD10 REMEDIATION
  1.  . I (FBSI=28)&(ICDMDE=10) F  D  Q:($G(FBAAOUT))!(XX1>0)
  1.  . . S XX1=$$ASKICD10(FBMPDT) S:XX1=-3 FBAAOUT=1
  1.  . . Q:XX1<0
  1.  . . S FBHCFA(28)=XX1
  1.  . . Q
  1.  . Q:($G(FBAAOUT))!((ICDMDE=10)&(FBSI=28))
  1.  . I (FBSI=28)&(ICDMDE=9) F  D  Q:($G(FBAAOUT))!(XX1>0)
  1.  . . S XX1=$$ASKICD9(FBMPDT) S:XX1="^" FBAAOUT=1
  1.  . . Q:XX1<0
  1.  . . S FBHCFA(28)=XX1
  1.  . . Q
  1.  . Q:($G(FBAAOUT))!((ICDMDE=9)&(FBSI=28))
  1.  . ;END 139
  1.  . N ICDVDT S ICDVDT=$G(FBMPDT)
  1.  . ;JAS - 08/23/13 - FB*3.5*139 (ICD10 REMEDIATION) - Modified next line for ICD-10.
  1.  . F  S DIR(0)="P"_$S(FBSI=30:"^353.1",FBSI=31:"O^353.2")_":EMZ" D HCFA1 Q:$G(FBAAOUT)  Q
  1.  Q:$G(FBAAOUT)
  1.  W !
  1.  I $$EXTPV^FBAAUTL5(FBPOV)'="01" D
  1.  . S FBSI=32,DIR(0)="Y",DIR("A")="Service connected condition"
  1.  . S DIR("?")="^W !!,""Respond by answering 'Yes' or 'No'."",! I $G(DFN) W !?1,*7,""Patient:  "",$$NAME^FBCHREQ2(DFN) D DIS^DGRPDB W !!"
  1.  . D HCFA1 I $D(DIRUT) S FBAAOUT=1 Q
  1.  Q
  1.  ;
  1. ASKICD9(FBINDT) ;JAS - 08/23/13 - FB*3.5*139 (ICD10 REMEDIATION)
  1.  N FBDX,EDATE,XSP
  1.  S EDATE=FBINDT ; edate is the date of interest for ICD9 diagnosis code lookup
  1.  S XSP="ICD DIAGNOSIS"
  1.  S FBDX=$$ENICD9^FBICD9(EDATE,XSP,"Y")
  1.  K EDATE,FBINDT
  1.  Q +FBDX
  1.  ; 
  1. ASKICD10(FBINDT) ; FB*3.5*139-JLG-ICD10 REMEDIATION
  1.  N FBDX,EDATE,DA,DP
  1.  S EDATE=FBINDT ; edate is the date of interest for ICD10 diagnosis code lookup
  1.  S DA=DFN,DP=162.03 ; these must be defined prior to calling $$ASKICD10
  1.  S FBDX=-1 S FBDX=$$ASKICD10^FBASF("PRIMARY DIAGNOSIS","","Y") ; returns -1 or ien of icd10 diagnosis code
  1.  K EDATE,FBINDT
  1.  Q FBDX
  1.  ;
  1. HCFA1 D ^DIR I $D(DTOUT)!($D(DUOUT)) S FBAAOUT=1 Q
  1.  I Y'=-1 D
  1.  .I DIR(0)["P" S FBHCFA(FBSI)=$P(Y,"^")
  1.  .I DIR(0)="Y" S FBHCFA(FBSI)=$S(Y=1:"Y",1:"N")
  1.  K DIR Q
  1. DESC N FBJ
  1.  I FBAASC=4,$D(^TMP($J,"FBWP",0)) S ^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,1,0)=^(0) F FBJ=1:1 Q:'$D(^TMP($J,"FBWP",FBJ,0))  S ^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,1,FBJ,0)=^(0)
  1.  Q