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 Dec 13, 2024@02:21:22 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
