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