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

IBUCVM.m

Go to the documentation of this file. 
  1. IBUCVM ;LL/ELZ-LONG TERM CARE CLOCK MAINTANCE ; 06-DEC-19
  1.  ;;2.0;INTEGRATED BILLING;**663,671,669,675,745**;21-MAR-94;Build 8
  1.  ;; Per VHA Directive 6402, this routine should not be modified
  1.  ;
  1.  ; This routine is used to perform the Urgent Care Visit Tracking
  1.  ; database Maintenance.
  1.  ;
  1.  Q
  1.  ;
  1. ENTER ; menu option main entry point
  1.  ;
  1.  N DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
  1.  ;
  1.  S IBQUIT=0  ;Don't quit.
  1.  ;
  1.  ; select a patient (screen out patients with no LTC clock and are
  1.  ; not LTC patients.
  1. LOOP K DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
  1.  ;
  1.  ; Clear temp global in case of stoppage during work
  1.  K ^TMP($J,"IBUCVM")
  1.  ;
  1.  ;Ask for the patient
  1.  N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
  1.  S DIC="^DPT(",DIC(0)="AEMNQ" W ! D ^DIC G:Y<1 EX
  1.  S DFN=+Y D DEM^VADPT
  1.  ;
  1.  S IBYR=$$ASKDT("Enter Year")
  1.  G:IBYR=-1 LOOP
  1.  ;
  1. MLOOP ; Entry/Loop tag to allow user to stay with the defined maintenance utility.
  1.  ;
  1.  S IBLCT=$$PRTVSTS(DFN,IBYR)
  1.  ;
  1.  ;Ask user to Add or Edit Visit
  1.  W !!    ; Space prompt.
  1.  S IBAE=$$GETMAINT
  1.  I IBAE=-1 G LOOP
  1.  ;
  1.  I IBAE="A" D ADDVST(DFN)
  1.  I IBAE="E" D EDITVST(IBLCT)
  1.  ;
  1.  D PAUSE(1)
  1.  ;
  1.  I IBQUIT=1 G LOOP
  1.  ; Clear temp global after work on the veteran is done.
  1.  K ^TMP($J,"IBUCVM")
  1.  G MLOOP
  1.  ;
  1. EX ;
  1.  D KVAR^VADPT
  1.  ;
  1.  Q
  1.  ;
  1. ASKDT(IBPRMT) ;Date input
  1.  N DIR,Y,X,DIROUT,DIRUT
  1.  I $G(IBPRMT)'="" S DIR("A")=IBPRMT
  1.  S DIR("B")=2019
  1.  S DIR(0)="F^4:4:K:X'?4N X"
  1.  D ^DIR I $D(DIRUT) Q -1
  1.  W " ",Y
  1.  Q Y
  1.  ;
  1. PRTVSTS(IBDFN,IBYR) ; Get the list of visits for the calendar year
  1.  ;
  1.  N IBZ,IBV,IBC,IBI,IBN,IBD,IBSTAT,IBDT,IBLDT,IBLDT1,IBPT,IBQUIT,IBVYR
  1.  ;
  1.  S IBC=0 ; Counter of Visits
  1.  ; Collect the list of visits
  1.  S IBI=0 F  S IBI=$O(^IBUC(351.82,"B",IBDFN,IBI)) Q:'IBI  D
  1.  . S IBD=$G(^IBUC(351.82,IBI,0))
  1.  . Q:'IBD
  1.  . S IBSTAT=$P(IBD,U,4)
  1.  . S IBDT=$P(IBD,U,3)
  1.  . S IBVYR=$E(IBDT,1,3)+1700    ; Convert visit date to calendar year
  1.  . I IBYR'=IBVYR Q
  1.  . S IBC=IBC+1
  1.  . S ^TMP($J,"IBUCVM","IBA",IBC)=IBDT,^TMP($J,"IBUCVM","IBA","D",IBDT,IBC)=IBI_U_IBD
  1.  ;
  1.  ;Reorganize in date order for display
  1.  S (IBLDT,IBLCT)=0
  1.  F  S IBLDT=$O(^TMP($J,"IBUCVM","IBA","D",IBLDT)) Q:'IBLDT  D
  1.  . S IBLDT1=0
  1.  . F  S IBLDT1=$O(^TMP($J,"IBUCVM","IBA","D",IBLDT,IBLDT1)) Q:'IBLDT1  D
  1.  . . S IBLCT=IBLCT+1
  1.  . . S ^TMP($J,"IBUCVM","IBP",IBLCT)=$G(^TMP($J,"IBUCVM","IBA","D",IBLDT,IBLDT1))
  1.  ;
  1.  W @IOF
  1.  S IBPT=$$PT^IBEFUNC(IBDFN)
  1.  W !,"Urgent Care Visits in "_IBYR_" for "_$P(IBPT,U),!
  1.  D LINE("=",80)
  1.  I 'IBC W "No Urgent Care Visits during this calendar year." Q 0
  1.  S IBV=IBLCT\3 I IBC#3 S IBV=IBV+1
  1.  F IBI=1:1:IBV D  Q:$G(IBQUIT)
  1.  . D:$D(IBQUIT) CHKPAUSE
  1.  . S IBN=IBI
  1.  . S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN))
  1.  . W !?5,$J(IBN,2),?10,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
  1.  . S IBN=IBI+IBV S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN)) I IBD'="" W ?30,$J(IBN,2),?35,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
  1.  . S IBN=IBI+(2*IBV) S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN)) I IBD'="" W ?55,$J(IBN,2),?60,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
  1.  Q IBLCT
  1.  ;
  1. PAUSE(IBEND) Q:'$$SCR()  ;Screen only
  1.  N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
  1.  S IBQUIT=0
  1.  Q:$E(IOST,1,2)'["C-"
  1.  S IOSL2=$S(IOSL>24:24,1:IOSL)
  1.  F IBJ=$Y:1:(IOSL2-4) W !
  1.  I $G(IBEND) S DIR("A")="Enter RETURN to continue or '^' to exit."
  1.  S DIR(0)="E"
  1.  D ^DIR
  1.  K DIR
  1.  I $G(DUOUT) S IBQUIT=1
  1.  I $G(IBEND) W @IOF
  1.  Q
  1.  ;
  1. CHKPAUSE ;Check pause
  1.  I $Y>(IOSL-5) D PAUSE Q:IBQUIT  W @IOF D LINE("-",80) W !
  1.  Q
  1.  ;
  1. SCR() Q $E(IOST,1,2)="C-" ; Screen
  1.  ;
  1.  ; Draw a line, of characters IBC, length IBN
  1. LINE(IBC,IBN) N IBL
  1.  I $L($G(IBC))'=1 S IBC="="
  1.  I +$G(IBN)=0 S IBN=80
  1.  S $P(IBL,IBC,IBN+1)=""
  1.  W IBL
  1.  Q
  1.  ;
  1.  ; Fotmatting row labels
  1. FRM(IBLBL,IBCUT) ;
  1.  I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
  1.  Q "  "_IBLBL_": "  ;;;$J("",26-$L(IBLBL))_":  "
  1.  ;
  1.  ;Ask the user for the type of work to do
  1. GETMAINT() ;
  1.  ;
  1.  ;RCMNFLG - Ask to print the Main report (Detailed) report.  0=No, 1=Yes
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ;
  1.  ; Prompt Summary or Detail version
  1.  S DIR("A")="(A)dd an Urgent Care Visit, (E)dit an existing Visit, or (Q)uit: "
  1.  S DIR(0)="SA^A:ADD;E:Edit;Q:Quit"
  1.  S DIR("?")="Select whether to Add a new Urgent Care visit, Edit an Existing visit, or Quit."
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  I Y="Q" Q -1
  1.  Q Y
  1.  ;
  1. ADDVST(IBDFN) ; Add a new UC visit for the patient
  1.  ;
  1.  N IBVST,IBINST,IBSTAT,IBBILL,IBCOMM,IBSITE,IBERROR,IBDUPFLG,IBELPG,IBOVRFLG,IBIND
  1.  ;
  1.  ;Initialize the error return array/Variable
  1.  S IBERROR=""
  1.  ;
  1.  S (IBVST,IBINST,IBSTAT,IBBILL,IBCOMM)="",IBDUPFLG=0
  1.  D SITE^IBAUTL   ; retrieve the Billing Site value from the IB Site Parameter File.  Store in IBSITE
  1.  S IBVST=$$GETVST
  1.  I $D(^TMP($J,"IBUCVM","IBA","D",IBVST)) S IBDUPFLG=1
  1.  Q:IBVST=-1
  1.  ; Retrieve Priority Group (future development)
  1.  S IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
  1.  S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)  ; IB*2.0*745
  1.  ;
  1.  S IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG)  ; IB*2.0*745
  1.  Q:IBSTAT=-1
  1.  S:IBSTAT=2 IBBILL=$$GETBILL
  1.  Q:IBBILL=-1
  1.  S:IBBILL'="" IBBILL=$$UP^XLFSTR(IBBILL)   ;Convert to upper case
  1.  S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG)  ; IB*2.0*745
  1.  Q:IBCOMM=-1
  1.  S IBOK=$$GETOK^IBECEA36(IBDUPFLG)
  1.  Q:IBOK'=1
  1.  D ADD^IBECEA38(IBDFN,IBSITE,IBVST,IBSTAT,IBBILL,IBCOMM,1,"",.IBERROR)
  1.  Q
  1.  ;
  1. EDITVST(IBLCT) ; Add a new UC visit for the patient
  1.  ;
  1.  N IBSTAT,IBBILL,IBCOMM,IBERROR,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBELPG,IBOK,IBOVRFLG,IBIND
  1.  ;
  1.  ;Ask user for visit to edit
  1.  S (IBSTAT,IBBILL,IBCOMM,IBERROR,IBVSITE,IBOVRFLG)=""
  1.  S IBVISIT=$$GETVISIT(IBLCT)
  1.  Q:IBVISIT=-1
  1.  ;
  1.  ;Get the visit info
  1.  S IBD=$G(^TMP($J,"IBUCVM","IBP",IBVISIT))
  1.  Q:IBD=""
  1.  S IBIEN=$P(IBD,U)
  1.  S IBVST=$P(IBD,U,4)
  1.  ;
  1.  ;get the Site name and code
  1.  I $P(IBD,U,3)'="" D
  1.  .  S IBSITECD=$$GET1^DIQ(4,$P(IBD,U,3)_",",99,"I")
  1.  .  S IBSITENM=$$GET1^DIQ(4,$P(IBD,U,3)_",",.01,"E")
  1.  .  S IBVSITE=$E(IBSITECD_"-"_IBSITENM,1,20)
  1.  ;
  1.  ;display the visit info
  1.  ;
  1.  W !!,"Date of Visit",?16,"Station",?39,"Status",?51,"Bill No.",?64,"Reason"
  1.  W !,"-------------",?16,"-------",?39,"------",?51,"--------",?64,"------"
  1.  W !,$$FMTE^XLFDT($P(IBD,U,4)),?16,IBVSITE,?39,$$GET1^DIQ(351.82,IBIEN_",",.04)
  1.  I $P(IBD,U,6)'="" W ?51,$P(IBD,U,6)
  1.  I $P(IBD,U,7)'=""  W ?64,$E($$GET1^DIQ(351.82,IBIEN_",",.06),1,19)
  1.  W !!
  1.  ;
  1.  ; Retrieve Priority Group (future development)
  1.  S IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
  1.  S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)  ; IB*2.0*745
  1.  ;
  1.  ;Prompt for Status change
  1.  S IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG)  ; IB*2.0*745
  1.  Q:IBSTAT=-1
  1.  ;
  1.  ;Prompt for Bill No. if status is billed
  1.  S:IBSTAT=2 IBBILL=$$GETBILL
  1.  Q:IBBILL=-1
  1.  S:IBBILL'="" IBBILL=$$UP^XLFSTR(IBBILL)   ;Convert to upper case
  1.  ;
  1.  ;Prompt for Comment if changed to Free or Not Counted
  1.  S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG)  ; IB*2.0*745
  1.  Q:IBCOMM=-1
  1.  ;
  1.  ;Confirm with user with no Duplicate Visit flag.
  1.  S IBOK=$$GETOK^IBECEA36(0)
  1.  Q:IBOK'=1
  1.  ;
  1.  ;Save the changes.
  1.  D UPDATE^IBECEA38(IBIEN,IBSTAT,IBBILL,IBCOMM,1,.IBERROR)
  1.  Q
  1.  ;
  1.  ;Ask the user for the type of work to do
  1. GETVST() ;
  1.  ;
  1.  ;RCMNFLG - Ask to print the Main report (Detailed) report.  0=No, 1=Yes
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ;
  1.  ; Prompt Summary or Detail version
  1.  S DIR("A")="Visit Date: "
  1.  S DIR(0)="DA^3190606:"_DT
  1.  S DIR("?")="The visit has to occur between 6/6/2019 and Today."
  1.  ;
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  Q Y
  1.  ;
  1. GETSTAT(IBDFN,IBVST,IBELPG,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBFRCT,IBRUR,IBSCSA,IBY
  1.  ;
  1.  ;Check for the override Key
  1.  S IBOVRFLG=0
  1.  S IBFRCT=0
  1.  ;
  1.  ;Add Prompts
  1.  I IBAE="A" D
  1.  . S DIR("A")="(F)REE,(B)ILLED, or (V)isit Only: "
  1.  . S DIR(0)="SA^1:FREE;2:BILLED;4:VISIT ONLY"
  1.  . S DIR("?")="Select whether the visit was a FREE, BILLED, or VISIT ONLY."
  1.  ;
  1.  ;Edit Prompts
  1.  I IBAE="E" D 
  1.  . S DIR("A")="(F)REE,(B)ILLED,(R)emoved, or (V)isit Only: "
  1.  . S DIR(0)="SA^1:FREE;2:BILLED;3:REMOVED;4:VISIT ONLY"
  1.  . S DIR("?")="Select whether the visit was a FREE, BILLED, REMOVED or VISIT ONLY."
  1.  ;
  1.  D ^DIR K DIR
  1.  ;
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  S IBY=Y
  1.  ;
  1.  I 'IBIND,IBELPG>6,$$KCHK^XUSRB("IBUC VISIT MAINT OVERRIDE"),IBY=1 D  Q:$G(Y)'=1 -1  ; IB*2.0*745
  1.  . K DIR  ; reinit the DIR Array
  1.  . ; Ask user for override
  1.  . S DIR(0)="YA",DIR("A")="This veteran is not eligible for a Free Visit.  Do you wish to Override?  : "
  1.  . D ^DIR
  1.  . I '$G(Y)!$G(DUOUT)!$G(DTOUT)!$G(DIRUT) S Y=0 Q
  1.  . ; Confirm the override
  1.  . S DIR(0)="YA",DIR("A")="Are you sure?  "
  1.  . D ^DIR
  1.  . I '$G(Y)!$G(DUOUT)!$G(DTOUT)!$G(DIRUT) S Y=0 Q
  1.  . S:$G(Y)=1 IBOVRFLG=1  ; Set override Flag to yes
  1.  ;
  1.  ;Validate that the veteran can receive a free visit
  1.  I 'IBIND,IBELPG>6,IBY=1,'IBOVRFLG D  Q -1  ; IB*2.0*745
  1.  . W !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
  1.  . W !,"Urgent Care Visit.",!
  1.  ;
  1.  I 'IBIND,IBELPG=6 D  ; IB*2.0*745
  1.  . ;Check to see if an RUR was completed.  If not, ask for the RUR and quit
  1.  . S IBRUR=$$PRTSARUR^IBECEA36
  1.  . I IBRUR=-1 D  Q
  1.  . . W !!,"Please send this for review by RUR."
  1.  . . S IBY=-1
  1.  . ;
  1.  . ;Check to see if visit related to the SC/SA.
  1.  . S IBSCSA=$$PRTVSTSA^IBECEA36
  1.  . ;
  1.  . I (IBSCSA=-1),(IBY=1) D
  1.  . . W !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
  1.  . . W !,"Urgent Care Visit.",!
  1.  . . S IBY=-1
  1.  ;
  1.  ; Exit if the PG 6 data checks failed
  1.  I IBY=-1 Q -1
  1.  ;
  1.  ; If a free visit, check to see if there are already 3 or more visits.  If so warn the user and exit.
  1.  S:IBY=1 IBFRCT=$P($$GETVST^IBECEA36(IBDFN,IBVST),U,2)
  1.  ;
  1.  K ^TMP($J,"IBUCVST")   ;Clean up TMP global created during GETVST^IBECEA36, not needed
  1.  ;
  1.  I (IBY=1),((IBELPG<7)!(IBOVRFLG=1)),(IBFRCT>2) D  Q -1
  1.  . W !!,"Per the Mission Act of 2018, this patient has already used their 3 free"
  1.  . W !,"visits for the calendar year.",!
  1.  Q IBY  ; IB*2.0*745
  1.  ;
  1. GETBILL() ;Ask the user for a Bill Number
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ;
  1.  S DIR("A")="Bill Number: "
  1.  S DIR(0)="FAO^^S X=$$UP^XLFSTR(X) K:'$$CHKBILL^IBUCVM(X) X"
  1.  S DIR("?")="Enter the Bill Number (including site) or ON HOLD if this visit was billed.  <ENTER> to continue."
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)  Q -1
  1.  Q Y
  1.  ;
  1. CHKBILL(IBBLNO) ; Validate that the Bill Number is a valid input
  1.  ;
  1.  ;Input:  IBBLNO - A bill number (with site) or ON HOLD.
  1.  ;
  1.  N IBBLIEN
  1.  ;
  1.  Q:IBBLNO="ON HOLD" 1     ; ON HOLD is a valid non Bill # entry
  1.  I IBBLNO'?3N1"-"1"K"6NU Q 0   ; Is not a valid Site and Bill Number format
  1.  S IBBLIEN=$O(^IB("ABIL",IBBLNO,""))
  1.  Q:IBBLIEN'="" 1
  1.  Q 0
  1.  ;
  1. GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG) ; Ask the user for the status reason (or default it if Status is FREE)
  1.  ;
  1.  ;Input: IBSTAT - The visit status (from code set in .06 field in file 351.82
  1.  ;                1 - FREE
  1.  ;                3 - REMOVED
  1.  ;                4 - VISIT ONLY
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ;
  1.  ;
  1.  ;If the status is to be FREE, auto populate the Reason based on Priority Group
  1.  I IBSTAT=1,IBELPG=6 Q 1          ;Defaults to reason SC/SA
  1.  I IBSTAT=1,IBELPG<6!IBIND Q 2    ;Defaults to reason MISSION Act  IB*2.0*745
  1.  I IBSTAT=1,IBOVRFLG=1 Q 6        ;Defaults to reason FRM Override
  1.  ;
  1.  ;If the status is VISIT ONLy, auto populate the Reason with No Copay Required
  1.  I IBSTAT=4 Q 5
  1.  ;
  1.  ;If the Status is Not Counted, ask user for the REMOVED reason.
  1.  S DIR("A")="Reason for (E)ntered in Error or (D)uplicate Visit: "
  1.  S DIR(0)="SA^3:Entered in Error;4:Duplicate Visit"
  1.  S DIR("?")="Select a reason to associate with the REMOVED visit status."
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)  Q -1
  1.  Q Y
  1.  ;
  1. GETVISIT(IBLCT) ; Get the IEN for visit to be edited.
  1.  ;
  1.  S DIR("A")="Enter Visit Number: "
  1.  S DIR(0)="NA^1:"_IBLCT_"^"
  1.  S DIR("?")="Enter the Visit to edit from the list above"
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!(Y<1)  Q -1
  1.  ;
  1.  Q +Y
  1.  ;
  1. DISPCHG(IBSTAT,IBBILL,IBREAS) ;Redisplay the changes requested
  1.  ;
  1.  W "The following updates will be made to this visit:"
  1.  W !!
  1.  Q