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

IBECEA36.m

Go to the documentation of this file.
  1. IBECEA36 ;ALB/CPM - Cancel/Edit/Add... Urgent Care Add Utilities ; 23-APR-93
  1. ;;2.0;INTEGRATED BILLING;**646,663,671,677,689,696,716**;21-MAR-94;Build 19
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to FILE #27.11 in ICR #5158
  1. ; Reference to FILE #2 in ICR #7182
  1. ;
  1. PRTUCVST(DFN,IBDT,IBDUPFLG) ; Print the UC visits for a calendar year
  1. ;
  1. N IBCT,IBDATA,IBFRCT,IBI,IBLDT,IBDCT
  1. K ^TMP($J,"IBUCVST") ;clear previous lookup if any
  1. S IBCT=$$GETVST(DFN,IBDT)
  1. S IBFRCT=$P(IBCT,U,2),IBDCT=$P(IBCT,U,3),IBCT=$P(IBCT,U)
  1. W !!,"This patient has had ",IBDCT," Urgent Care "_$S(IBCT=1:"visit",1:"visits")," this calendar year:",!
  1. ;
  1. ;Display the visits...
  1. I IBCT>0 D
  1. . W !,"Date of Visit",?16,"Station",?37,"Status",?48,"Bill No.",?61,"Reason"
  1. . W !,"-------------",?16,"-------",?37,"------",?48,"--------",?61,"------"
  1. . S IBLDT=0
  1. . F S IBLDT=$O(^TMP($J,"IBUCVST",IBLDT)) Q:'IBLDT D
  1. . . I IBLDT=IBDT S IBDUPFLG=1
  1. . . S IBI=0
  1. . . F S IBI=$O(^TMP($J,"IBUCVST",IBLDT,IBI)) Q:'IBI D
  1. . . . S IBDATA=^TMP($J,"IBUCVST",IBLDT,IBI)
  1. . . . Q:IBDATA=""
  1. . . . W !,$P(IBDATA,U),?16,$P(IBDATA,U,2),?37,$P(IBDATA,U,3)
  1. . . . I $P(IBDATA,U,4)'="" W ?48,$P(IBDATA,U,4)
  1. . . . I $P(IBDATA,U,5)'="" W ?61,$E($P(IBDATA,U,5),1,19)
  1. W !
  1. K ^TMP($J,"IBUCVST") ;clear lookup to clean up
  1. Q IBCT_U_IBFRCT
  1. ;
  1. GETVST(DFN,IBDT) ;Retrieve the UC visits as recorded in VistA during the calendar year being
  1. ; being billed
  1. ;
  1. ; Returns:
  1. ; Total Count of visits ^ Total Free Count of Visits ^ Total Display Count (no REMOVED) visits
  1. ;
  1. N IBCAL,IBCT,IBI,IBSITE,IBSTAT,IBCMT,IBBILL,IBBLCMT,IBSITECD,IBSITENM,IBVDT,IBDCT
  1. ;
  1. S (IBDCT,IBCT,IBFRCT,IBI)=0,(IBBILL,IBCMT)=""
  1. ;determine calendar year(ADD 1700 to first three digits in the FileMan date
  1. S IBCAL=+$E(IBDT,1,3)
  1. ;Loop through the tracking DB to find all of the visits for that calendar year.
  1. F S IBI=$O(^IBUC(351.82,"B",DFN,IBI)) Q:'IBI D
  1. . S IBDATA=$G(^IBUC(351.82,IBI,0))
  1. . S IBVDT=$P(IBDATA,U,3)
  1. . ; Only retrieve the visits from the calendar year being billed
  1. . Q:$E(IBVDT,1,3)'=IBCAL
  1. . I $P(IBDATA,U,2)'="" D
  1. . . S IBSITE=$$GET1^DIQ(351.82,IBI_",",.02,"I")
  1. . . S IBSITECD=$$GET1^DIQ(4,IBSITE_",",99,"I")
  1. . . S IBSITENM=$$GET1^DIQ(4,IBSITE_",",.01,"E")
  1. . . S IBSITE=$E(IBSITECD_"-"_IBSITENM,1,20)
  1. . S IBSTAT=$$GET1^DIQ(351.82,IBI_",",.04)
  1. . S:IBSTAT'="REMOVED" IBDCT=IBDCT+1 ; Moved from above and prevented REMOVED visits from counting
  1. . S IBCT=IBCT+1 ; Moved from above and prevented REMOVED visits from counting
  1. . S:IBSTAT="FREE" IBFRCT=IBFRCT+1
  1. . S IBBILL=$P(IBDATA,U,5)
  1. . S IBBLCMT=""
  1. . S:IBBILL'?1N.N IBBLCMT=IBBILL ;If the bill number has text, then it is a bill from an external site.
  1. . S IBCMT=$$GET1^DIQ(351.82,IBI_",",.06)
  1. . ; Still need to add comments, convert date to external, and convert site to display
  1. . S ^TMP($J,"IBUCVST",IBVDT,IBCT)=$$FMTE^XLFDT(IBVDT)_U_$G(IBSITE)_U_IBSTAT_U_IBBLCMT_U_IBCMT
  1. Q IBCT_U_IBFRCT_U_IBDCT
  1. ;
  1. PRTMSSN ; Print the Mission Act Exemption Message (May get moved to IB ERROR File to use IB ERROR functionality)
  1. ;
  1. W !,"Per the MISSION Act of 2018, this patient is allowed 3 free visits per",!,"calendar year",!
  1. Q
  1. ;
  1. PRTUCUPD ; Print the UC Visit Tracking DB has been updated.
  1. ;
  1. W !,"The patient's Urgent Care visit tracking has been updated.",!
  1. Q
  1. ;
  1. PRTSARUR() ; Print the UC SA message for PG 6 vets.
  1. N DIR,DIRUT,DUOUT,X,Y,IBY
  1. S IBY=-1 ; Default exit value
  1. W !
  1. S DIR(0)="YA",DIR("A",1)="This patient may be covered by a Special Authority. Has this visit been",DIR("A")="reviewed by RUR? : "
  1. D ^DIR
  1. Q:$D(DIRUT) IBY
  1. Q:$D(DUOUT) IBY
  1. Q:'Y IBY ; user selected No
  1. Q 1 ;Otherwise, the answer was yes
  1. ;
  1. PRTNORUR ; Print the info message if no RUR completed PG 6 vet copays.
  1. W !!,"Please send this for review by RUR before entering this copay.",!
  1. W !,"This charge was not processed. The patient's Urgent Care visit tracking was not",!,"updated.",!
  1. Q
  1. ;
  1. UCCHRG2(DFN,IBDT) ; Process Urgent Care Copay Charge
  1. ; set the initial charge to $30
  1. ; Undeclared parameters
  1. ; IBFEE - Flag for Community Care Copays
  1. ; IBUNIT - (Default 1) # units for the charge
  1. ; IBCHG - Default Copay to charge
  1. ; DFN - Patient IEN
  1. ;
  1. N IBIND,IBTYPE,IBPRI,IBUCVT,IBCT,IBFRCT,IBRESP,IBOK,IBDUPFLG ; Patient Enrollment Group/UC Visit Tracking storage flag
  1. S IBCHG=30,IBUNIT=1 ;initial copay amount
  1. S (IBDT,IBTO)=IBFR,IBX="O",(IBTYPE,IBUNIT)=1,IBEVDA="*",IBDUPFLG=0
  1. ;
  1. ; Ask for other UC copays for the year that are not at this site (future development)
  1. ;
  1. ; Retrieve Priority Group
  1. S IBPRI=$$GETELGP(DFN,IBDT) ;dbia 5158
  1. S IBIND=$$INDCHK^IBINUT1(IBDT,DFN) ; IB*2.0*716
  1. ;
  1. ; Process Enrollment Priority Groups 7 and 8
  1. I 'IBIND,IBPRI>6 D Q ; IB*2.0*716
  1. . S IBCT=+$$PRTUCVST(DFN,IBDT,.IBDUPFLG)
  1. . ; Call CTBB^IBECEAU3 to confirm or substitute amount of Copay
  1. . D CTBB^IBECEAU3
  1. . ;Set UC Visit Tracking flag to Billed
  1. . S IBUCVT=1
  1. ;
  1. ; Process Enrollment Priority Groups 1 to 5
  1. I IBIND!(IBPRI<6) D Q ; IB*2.0*716
  1. . S IBCT=$$PRTUCVST(DFN,IBDT,.IBDUPFLG) ;Retrieve the number of visits and display them
  1. . S IBFRCT=$P(IBCT,U,2),IBCT=$P(IBCT,U)
  1. . I IBFRCT<3 D Q ; SC vet has < 3 Free UC visits print statements and quit
  1. . . D PRTMSSN ; display the mission act statement
  1. . . S IBOK=$$GETOK(IBDUPFLG) ; Confirm with the user that it is ok to proceed.
  1. . . I IBOK D
  1. . . . D ADDVST(DFN,IBDT,"",1,2)
  1. . . . D PRTUCUPD ; display the Patient Tracker statement.
  1. . . S IBY=-1 ; Set the quit flag, but don't provide an error message.
  1. . ;
  1. . ; Call CTBB^IBECEAU3 to confirm or substitute amount of Copay
  1. . D CTBB^IBECEAU3
  1. ;
  1. ;PG 6 processing
  1. ;
  1. ;Ask user if RUR was completedIf there were Fewer than 3 visits
  1. S IBCT=$$GETVST(DFN,IBDT) ;Retrieve the number of visits
  1. S IBFRCT=$P(IBCT,U,2),IBCT=$P(IBCT,U)
  1. S IBRESP="" ; Initialize IBRESP
  1. I IBFRCT<3 D Q:IBRESP<0 ; SC vet has < 3 Free UC visits print statements and quit
  1. . S IBRESP=$$PRTSARUR
  1. . I IBRESP<0 D PRTNORUR S IBY=-1
  1. ;
  1. ; Display the visits
  1. S IBCT=$$PRTUCVST(DFN,IBDT,.IBDUPFLG) ;Retrieve the number of visits and display them
  1. S IBFRCT=$P(IBCT,U,2),IBCT=$P(IBCT,U)
  1. ;
  1. S IBRESP=1 ;Reset the temporary response flag variable. Assume patient will be charged.
  1. I IBFRCT<3 D Q:$G(IBY)=-1 ; SC vet has < 3 Free UC visits print statements and quit
  1. . S IBRESP=$$PRTVSTSA
  1. . I IBRESP=-1 S IBY=-1 Q
  1. . I +$G(IBRESP)=1 D
  1. . . D PRTMSSN ; display the mission act statement
  1. . . S IBOK=$$GETOK(IBDUPFLG) ; Confirm with the user that it is ok to proceed.
  1. . . I IBOK D
  1. . . . D ADDVST(DFN,IBDT,"",1,1) ;
  1. . . . D PRTUCUPD ; display the Patient Tracker statement.
  1. . . S IBY=-1 ; Set the quit flag, but don't provide an error message.
  1. ;
  1. ; Call CTBB^IBECEAU3 to confirm or substitute amount of Copay, then update the UC Visit Database
  1. D CTBB^IBECEAU3
  1. Q
  1. ;
  1. ADDVST(DFN,IBDT,IBN,IBSTATUS,IBREAS,IBSITE) ; Update the Visit Tracking DB
  1. ;
  1. ;Input:
  1. ; DFN - (Required) Patient IEN (from file #2)
  1. ; IBDT - (Required) Date of Visit
  1. ; IBN - (Required) Copay IEN (from file #350)
  1. ; IBSTATUS - (Required) Urgent Care Visit Billing Status
  1. ; 1 - FREE
  1. ; 2 - BILLED (i.e. copay was created)
  1. ; 3 - Not Counted (i.e. UC visit was cancelled at the site)
  1. ; 4 - Visit Only (Visit counted, but no bill produced)
  1. ; IBREAS - Code # for the comment
  1. ; IBCMT - Add SC/SA/SV (1) comment if adding a visit for a PG6.
  1. ; IBSITE - (Optional) Site where the copay was charged. Defaults to IBFAC if not passed in.
  1. ;
  1. N FDA,FDAIEN,IBSITE,IBBILL,IBERROR,IBBLSTAT
  1. ;
  1. ;check for a defined site in the copay file
  1. ;WCJ;IB696
  1. ;S:$G(IBSITE)="" IBSITE=$$GET1^DIQ(350,$G(IBN)_",",.13,"I")
  1. I $G(IBSITE)="" S IBSITE=$$STA^XUAF4($$GET1^DIQ(350,$G(IBN)_",",.13,"I")) S:IBSITE]"" IBSITE=+IBSITE
  1. ;
  1. ;Otherwise, default to IBFAC
  1. ;WCJ;IB696;IBFAC can be an IEN for a child and not the actual facility so it may not be the IEN for the actual site. Pretty sure IBSITE will already be defined
  1. ;but if we need to use IBFAC, let's turn it into a site number
  1. ;S:$G(IBSITE)="" IBSITE=IBFAC
  1. S:$G(IBSITE)="" IBSITE=$$STA^XUAF4(IBFAC)
  1. ;
  1. S IBBILL=$$GET1^DIQ(350,$G(IBN)_",",.11,"E")
  1. S IBREAS=$G(IBREAS)
  1. ;
  1. ;If no Bill Number, check to see if on hold. If so, store ON HOLD
  1. I IBBILL="" D
  1. . S IBBLSTAT=$$GET1^DIQ(350,$G(IBN)_",",.05,"I")
  1. . ; If bill status is 8 (On Hold) then store On Hold as the Bill Number
  1. . I IBBLSTAT=8 s IBBILL="ON HOLD"
  1. ;
  1. ;Call utility to add to DB
  1. D ADD^IBECEA38(DFN,IBSITE,IBDT,IBSTATUS,IBBILL,IBREAS,1,"",.IBERROR)
  1. ;
  1. Q
  1. ;
  1. PRTVSTSA() ; Print the UC SA message for PG 6 vets.
  1. N DIR,DIRUT,DUOUT,X,Y,IBY
  1. S IBY=-1 ; Default exit value
  1. S DIR(0)="YA",DIR("A")="Is this visit related to the patient's Special Authority? : "
  1. D ^DIR
  1. W ! ;force a line feed between the messages
  1. Q:$D(DIRUT) IBY
  1. Q:$D(DUOUT) IBY
  1. Q:'Y Y ; user selected No
  1. Q 1 ;Otherwise, the answer was yes
  1. ;
  1. GETOK(IBDUPFLG) ; Ask the user if it is OK to proceed.
  1. N DIR,DIRUT,DUOUT,X,Y,IBY
  1. S IBDUPFLG=$G(IBDUPFLG)
  1. I IBDUPFLG D
  1. . S DIR(0)="YA",DIR("A")="Duplicate visit detected. Is the date of service correct? :"
  1. . D ^DIR
  1. . W ! ;force a line feed between the messages
  1. ;
  1. ; If the user enters No
  1. I IBDUPFLG,(+$G(Y)'=1) D Q +$G(Y)
  1. . W !!,"Visit Date not confirmed - Visit Tracking Database not updated."
  1. ;
  1. S DIR(0)="YA",DIR("A")="Is the above information correct? : "
  1. D ^DIR
  1. W ! ;force a line feed between the messages
  1. Q +Y ;Otherwise, the answer was yes
  1. ;
  1. GETELIG(IBDFN,IBOUT) ; This function returns all of the Enrollment Priority Group Entries for the specified patient
  1. ;
  1. ;INPUT - IBDFN - Patient IEN to look up
  1. ;OUTPUT - IBOUT - (Optional) Output Array containing entries in the Patient Enrollment file (#27.11) for the patient.
  1. ; Function call:
  1. ; -1^<Error Message> - Error occured
  1. ; total of entries found
  1. ;
  1. Q:$G(IBDFN)="" "-1^Patient not defined for Enrollment Lookup"
  1. S:$G(IBOUT)="" IBOUT=0 ;
  1. ;
  1. N IBERR
  1. ;
  1. S IBERR="" ;Initialize Error Array
  1. ;
  1. ;FIND^DIC structure
  1. ;D FIND^DIC(file[,iens][,fields][,flags],[.]value[,number][,[.]indexes][,[.]screen][,identifier][,target_root][,msg_root]) ; this line is just for reference
  1. ;
  1. ; get all enrollment groups for the specified patient.
  1. ; screen output to only get entries with "verified" enrollment status (field 27.11/.04) IB*2.0*689
  1. D FIND^DIC(27.11,"","@;.07I;.08I","QEP",IBDFN,"","C","I $P(^DGEN(27.11,Y,0),U,4)=2","","IBOUT","IBERR")
  1. Q +IBOUT("DILIST",0)
  1. ;
  1. GETELGP(IBDFN,IBDOS) ; Function to return a patient's Enrollment Priority Group For a specified Date of Service
  1. ;
  1. ;INPUT: IBDFN - ibPatient IEN (File #2)
  1. ; IBDOS - Date of Service
  1. ;OUTPUT: GETELGP - Patient's Enrollment Group on the specified DAte of service.
  1. ; or
  1. ; -1^<error message> if Error occurred during Enrollment Lookup
  1. ;
  1. N IBOUT,IBCHK,I,IBDATA,IBELIG,IBEFDT,IBELKUP,IBOLD,IBSCEFDT,IBLKDT
  1. ;
  1. S IBOUT="" ;initialize the Enrollment groupt array
  1. S IBCHK=$$GETELIG(IBDFN,.IBOUT)
  1. ;
  1. I +IBCHK=-1 Q IBCHK ; Error occurred. Quit and pass error message to calling function
  1. I +IBCHK=0 Q 8 ;no entries in the Patient Enrollment File, assume PG 8 and quit
  1. ;
  1. ; Add sorted by effective Date node. If multiple on the same day, store the lowest non NULL entry (NULL is assumed to PG 8)
  1. S I=0
  1. F S I=$O(IBOUT("DILIST",I)) Q:'I D
  1. . S IBDATA=$G(IBOUT("DILIST",I,0))
  1. . S IBELIG=$P(IBDATA,U,2),IBEFDT=$P(IBDATA,U,3)
  1. . S:IBELIG="" IBELIG=8
  1. . S IBOLD=$G(IBOUT("SDATE",IBEFDT))
  1. . ; If multiple entries with the same effective date, don't update if new eligibility is not less than the currently sorted eligibilty
  1. . I IBOLD'="",(IBELIG'<IBOLD) Q
  1. . S IBOUT("SDATE",IBEFDT)=IBELIG
  1. ;
  1. ;Lookup up the Enrollment Group,
  1. ; first for an exact effective date match,
  1. S IBELKUP=$G(IBOUT("SDATE",IBDOS))
  1. I IBELKUP'="" Q +IBELKUP
  1. ; else look for the effective date.
  1. S IBLKDT=$O(IBOUT("SDATE",IBDOS),-1)
  1. I IBLKDT="" Q 8 ; No Enrollment for that date found, assume PG 8
  1. S IBELKUP=$G(IBOUT("SDATE",IBLKDT))
  1. ;
  1. Q:IBELKUP<7 IBELKUP ; If Priority Group is <7, then don't perform a retro lookup and quit
  1. ;
  1. ; Retro award lookup for PG 7's and 8's
  1. S IBSCEFDT=$$GET1^DIQ(2,IBDFN_",",.3014,"I") ; effective SC % date DBIA 7182
  1. ;
  1. ; If no SC % Effective Date, then quit with previously found PG.
  1. Q:$G(IBSCEFDT)="" IBELKUP
  1. ;
  1. ;Check to see of there is a Retro award. Effective SC % date < EG Effective Date
  1. I IBSCEFDT'<IBLKDT Q IBELKUP
  1. ;
  1. ;perform a new lookup using the SC % Effective Date
  1. I IBSCEFDT'="",$D(IBOUT("SDATE",IBSCEFDT)) S IBELKUP=IBOUT("SDATE",IBSCEFDT) ; IB*2.0*689
  1. ;
  1. Q +IBELKUP
  1. ;
  1. IBEDIT() ;Check to see if the user has the IB EDIT Key to allow the user to add a copay
  1. ;
  1. I '$D(^XUSEC("IB EDIT",DUZ)) D Q 0
  1. . W !!,"IB EDIT Key Required to Add a Charge" ; Write the message
  1. . R !!,?10,"Press any key to continue. ",IBX:DTIME
  1. ;
  1. Q 1